2 implicit real *8(a-h, o-z)
3 common /consta/vl, pi, xmat, rpel, qst
4 common /gaus13/h(13), t(13)
5 common /gaus17/h1(17), t1(17)
6 common /radia/trt, rmoy, xintf, crae
7 data crae, xintf/2.81793910e-13, .86967/
8 data vl, xmat, rpel, qst/2.99792458e10, 938.27231, 28.17938e-14, 1./
9 data h/.040484004, .092121499, .138873510, .178145981, .207816048, .226283180, .232551553, .226283180, .207816048, &
10 .178145981, .138873510, .092121499, .040484004/
11 data t/ -.984183055, -.917598399, -.801578091, -.642349339, -.448492751, -.230458316, 0., .230458316, .448492751, &
12 .642349339, .801578091, .917598399, .984183055/
13 data h1/ -.990575473, -.950675522, -.880239154, -.781514004, -.657671159, -.512690537, -.351231763, -.178484181, &
14 0., .178484181, .351231763, .512690537, .657671159, .781514004, .880239154, .950675522, .990575473/
15 data t1/.024148303, .055459529, .085036148, .111883847, .135136368, .154045761, .168004102, .176562705, &
16 .179446470, .176562705, .168004102, .154045761, .135136368, .111883847, .085036148, .055459529, .024148303/
17 common /randu/ck(15), kmax
20 data (ck(j), j=1, 7)/.98933556, -.68838689, .28191718, -.66389307e-01, .87406854e-02, -.59534602e-03, &
30 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
50 implicit real *8(a-h, o-z)
51 parameter(ncards=64, iptsz=100002, maxcell=3000, maxcell1=3000)
52 common /itvole/itvol, imamin
53 common /consta/vl, pi, xmat, rpel, qst
54 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
56 common /fene/wdisp, wphas, wx, wy, rlim, ifw
57 common /dyn/tref, vref
58 common /dyni/vrefi, trefi, fhinit, acpt
60 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
61 common /azlist/icont, iprin
62 common /carac/cara(10)
63 common /compt/nrres, nrtre, nrbunc, nrdbun
64 common /compt1/ndtl, ncavmc, ncavnm
65 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
66 common /faisc/f(10, iptsz), imax, ngood
67 common /tapes/in, ifile, meta
68 common /shif/dtiph, shift
69 common /tilt/tipha, tix, tiy, shifw, shifp
70 common /bloc21/be, apb(2), layl, layx, rabt
72 common /poro/irot1, irot2
74 common /etchas/fractx, fracty, fractl
75 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
78 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
79 common /etcha3/ichxyz(iptsz)
82 common /tabsch/ideg, nn, pchoix
84 common /cptemit/xltot(maxcell1), nbemit
89 common /qskew/qtwist, iqrand, itwist, iaqu
90 common /femt/iemgrw, iemqesg
91 common /mode/eflvl, rflvl
92 common /aerp/vphase, vfield, ierpf
95 common /histo/centre(6)
96 common /grparm/glim(4, 2), glim1(4, 2), glim2(4, 2), patitl, ngraphs(100), idwdp, igrprm, ngrafs
97 common /zones/frms(6), nzone
98 logical chasit, shift, itvol, imamin
99 logical ichaes, iesp, ifield, ialin, itwist, iemgrw
100 character *80 cara, cmnt, text, patitl, ofeldf, ofelds
101 character *80 davprt(maxcell1)
102 character *8 kle(ncards), kley
106 common /cespch/nchge, ichsp, nppi
109 common /alin/xl, yl, xpl, ypl
110 common /trcmp/pchoixa
111 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
112 common /mcs/imcs, ncstat, cstat(20)
115 common /rayshy/iraysh
116 common /trfq/icour, ncell
117 common /newref/dephas, dewref, iref, irefw
121 common /rf1ptq/tvolt, avolt, fph, mlc, nceltot
122 common /strip/atm, qs, atms, ths, qop, sqst(6), anp, nqst
123 common /grot/rzot, izrot
125 common /isector/nsector, nsprint
127 common /xposi/xpost(10), xlce(2), xpax(2), iscx(2)
129 logical ifcont, mg, ffound
132 common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
133 common /t3dfld/fldctr(15), zend(15), t3d
135 character *128 trace3h, trace3t, tif, tifa, tifb
140 logical iraysh, cfound
141 data kle/
'GEBEAM',
'INPUT',
'RDBEAM',
'ETAC',
'DRIFT',
'QUADRUPO',
'SEXTUPO',
'QUADSXT',
'SOLENO',
'SOQUAD', &
142 'BMAGNET',
'CAVMC',
'CAVSC',
'FIELD',
'HARM',
'BUNCHER',
'RFQCL',
'NEWF',
'NREF',
'SCDYNAC',
'SCDYNEL',
'SCPOS', &
143 'TILT',
'TILZ',
'CHANGREF',
'TOF',
'REJECT',
'ZROT',
'ALINER',
'ACCEPT',
'EMIT',
'EMITGR',
'COMMENT',
'WRBEAM', &
144 'ENVEL',
'CHASE',
'RWFIELD',
'RANDALI',
'TWQA',
'EMIPRT',
'MMODE',
'RFQPTQ',
'STRIPPER',
'STEER',
'ZONES', &
145 'PROFGR',
'SECORD',
'RASYN',
'FDRIFT',
'FSOLE',
'EGUN',
'COMPRES',
'STOP',
'REFCOG',
'FPART',
'QUAELEC', &
146 'QUAFK',
'CAVNUM',
'EDFLEC',
'EMITL',
'RFKICK',
'FIRORD',
'DCBEAM',
'T3D'/
148 character *80 inarg, myarg(10), myfile, wfile, infiln, shortl
150 logical g77, gfortran
165 if (g77) gfortran = .false.
169 call get_command_argument(narg, inarg)
170 if (len_trim(inarg)==0)
exit 174 myarg(narg) = trim(inarg)
177 write (6, *)
'Compatible with g77' 185 if (text(1:1)/=
'-')
then 187 write (6, 2917) myarg(i)
188 2917
format (
'Input file: ', a)
192 open (7, file=myarg(i), status=
'unknown')
199 write (6, *)
'Using MINGW gfortran format on MSWindows' 201 if (myarg(i)==
'-h')
then 204 write (6, *)
'Command format:' 205 write (6, *)
'dynacv6_0 [-h] [-mingw] [file1]' 206 write (6, *)
'where file1 is the input file, describing ',
'the beamline' 207 write (6, *)
'Optional arguments:' 208 write (6, *)
'-h will list the argument options (this ',
'list)' 213 if (.not. ffound)
then 214 write (6, *)
'Error: Input file name required' 216 write (6, *)
'dynacv6_0 -h' 217 write (6, *)
'for syntax' 252 open (16, file=
'dynac.long', status=
'unknown')
253 open (12, file=
'dynac.short', status=
'unknown')
254 open (71, file=
'dynac.print', status=
'unknown')
255 open (50, file=
'dynac.dmp', status=
'unknown')
256 open (61, file=
'beam_core.dst', status=
'unknown')
257 open (60, file=
'beam_remove.dst', status=
'unknown')
258 open (11, file=
'dynac_in_pr.dst', status=
'unknown')
259 open (66, file=
'emit.plot', status=
'unknown')
286 open (13, file=
'emlg.data', status=
'unknown')
334 trace3h(kt3h) =
' $DATA' 431 3101
format (
'****** DYNAC V6.0R15 (Beta test), 30-Dec-2015 *******')
433 write (16, *)
'Input file: ', infiln
434 write (12, *)
'Input file: ', infiln
441 if (iitime(1:2)==
'01') text(5:7) =
'Jan' 442 if (iitime(1:2)==
'02') text(5:7) =
'Feb' 443 if (iitime(1:2)==
'03') text(5:7) =
'Mar' 444 if (iitime(1:2)==
'04') text(5:7) =
'Apr' 445 if (iitime(1:2)==
'05') text(5:7) =
'May' 446 if (iitime(1:2)==
'06') text(5:7) =
'Jun' 447 if (iitime(1:2)==
'07') text(5:7) =
'Jul' 448 if (iitime(1:2)==
'08') text(5:7) =
'Aug' 449 if (iitime(1:2)==
'09') text(5:7) =
'Sep' 450 if (iitime(1:2)==
'10') text(5:7) =
'Oct' 451 if (iitime(1:2)==
'11') text(5:7) =
'Nov' 452 if (iitime(1:2)==
'12') text(5:7) =
'Dec' 454 text(9:10) = iitime(4:5)
456 text(14:15) = iitime(7:8)
458 text(20:27) = iitime(10:17)
461 text(1:11) = iitime(1:11)
462 text(12:15) = iitime(21:24)
464 text(20:27) = iitime(12:19)
466 write (6, 789) text(1:27)
467 789
format (
'Started on ', a27)
468 write (16, *)
'Started on ', text(1:27)
469 write (12, *)
'Started on ', text(1:27)
470 call cpu_time(exstrt)
472 read (in, 3333) titre(1:80)
473 write (16, 3334) titre(1:80)
474 write (12, 3334) titre(1:80)
476 3334
format (1x, a80)
480 read (in, 3333) cmnt(1:80)
481 if (cmnt(1:1)==
';')
then 482 write (16, 3334) cmnt(1:80)
488 if (kley==kle(i))
then 511 write (16, *)
' TYPE CODE:GEBEAM********* ' 513 write (16, *)
'********************************' 534 write (16, *)
' TYPE CODE:INPUT ********' 536 write (16, *)
'********************************' 539 write (16, *)
'TYPE CODE:RDBEAM **********' 558 read (in, 3333) myfile(1:80)
559 write (16, *)
'Distribution file: ', myfile(1:80)
560 open (55, file=myfile, status=
'unknown')
562 write (16, *)
'********************************' 565 write (16, *)
'TYPE CODE:ETAC **********' 567 trace3h(kt3h) =
'ERROR: ETAC not supported' 569 write (16, *)
'********************************' 572 write (16, *)
'TYPE CODE:DRIFT **********' 575 write (tif, 6001) kt3t, kt3t, 10.*dl
576 6001
format (
' nt(', i4,
')= 1, a(1,', i4,
')=', f12.6)
579 write (16, *)
'********************************' 585 write (16, *)
'TYPE CODE:QUADRUPO**********' 586 read (in, *) xlqua, bquad, rg
588 write (tif, 6002) kt3t, kt3t, 10.*bquad/rg, xlqua*10.
589 6002
format (
' nt(', i4,
')= 3, a(1,', i4,
')= ', f9.5,
' , ', f9.5)
591 call qalva(bquad, xlqua, rg)
592 write (16, *)
'********************************' 599 write (16, *)
'TYPE CODE:SEXTUPO**********' 600 read (in, *) imk2, arg, xlsex, rg
601 call sextu(imk2, arg, xlsex, rg)
602 write (16, *)
'********************************' 613 write (16, *)
'TYPE CODE:QUADSXT**********' 614 read (in, *) iksq, args, argq, xlqua, rg
615 call qasex(iksq, args, argq, xlqua, rg)
616 write (16, *)
'********************************' 622 write (16, *)
'TYPE CODE SOLENO**********' 623 read (in, *) imks, xlsol, arg
625 write (16, *)
'********************************' 639 write (16, *)
'TYPE CODE:SOQUAD**********' 640 read (in, *) iksq, args, argq, xlsol, rg
641 call solquad(iksq, args, argq, xlsol, rg)
642 write (16, *)
'********************************' 678 read (in, *) angl, rmo, baim, xn, xb
679 read (in, *) pent1, rab1, ek1, ek2, apb(1)
681 if (apb(1)/=0. .and. ek1<0.) ek1 = 0.5
682 read (in, *) pent2, rab2, sk1, sk2, apb(2)
684 if (apb(2)/=0. .and. sk1<0.) sk1 = 0.5
688 write (tif, 6005) kt3t, kt3t, pent1, 10.*abs(rmo), 20.*apb(1), ek1, ek2
689 6005
format (
' nt(', i4,
')= 9, a(1,', i4,
')=', f9.5,
' , ', f9.2,
' , ', f9.2,
' , ', f9.2,
' , ', f9.2)
693 write (tif, 6006) kt3t, kt3t, angl, 10.*abs(rmo)
694 6006
format (
' nt(', i4,
')= 8, a(1,', i4,
')=', f9.5,
' , ', f9.2,
' , 0 , 0 ')
698 write (tif, 6005) kt3t, kt3t, pent2, 10.*abs(rmo), 20.*apb(2), sk1, sk2
702 call aimalv(angl, rmo, baim, xn, xb, ek1, ek2, pent1, rab1, sk1, sk2, pent2, rab2)
703 write (16, *)
'********************************' 709 write (16, *)
'TYPE CODE:CAVMC **********' 711 write (16, *)
'********************************' 715 write (16, *)
'TYPE CODE:CAVSC **********' 717 write (16, *)
'********************************' 725 write (16, *)
'TYPE CODE: FIELD **********' 726 write (16, *)
'ELECTRIC FIELD (z, E(z) ) ' 728 read (in, 3333) myfile(1:80)
731 iostats = int(ftell(20))
732 if (iostats==-1)
then 734 open (20, file=myfile, status=
'unknown')
735 write (16, *)
'Opening field file: ', myfile(1:80)
738 if (ofeldf/=myfile)
then 739 write (16, *)
'Closing field file: ', ofeldf
740 write (16, *)
'Opening field file: ', myfile(1:80)
742 open (20, file=myfile, status=
'unknown')
750 write (16, *)
' * Read the cavity field from ', myfile(1:80)
752 write (16, *)
'********************************' 755 write (16, *)
' TYPE CODE: HARM **********' 756 write (16, *)
'ELECTRIC FIELD (Fourier series expansion)' 758 write (16, *)
'********************************' 765 write (16, *)
'TYPE CODE:BUNCHER ************************' 766 read (in, *) pv, pdp, pharm, prlim
767 write (16, 7777) pv, pdp, prlim
768 7777
format (
' BUNCHER CAVITY ', /,
' Voltage ', e12.5,
' MV', /,
' RF Phase ', e12.5,
' deg', &
769 ' Aperture Radius ', e12.5,
' cm')
771 write (tif, 6007) kt3t, kt3t, pv, pdp, pharm
772 6007
format (
' nt(', i4,
')=10, a(1,', i4,
')=', f9.5,
' , ', f9.2,
' , 1 , 1 , ', f5.1)
775 call bunparm(pv, pdp, pharm, prlim)
776 write (16, *)
'********************************' 779 write (16, *)
'TYPE CODE:RFQCL ************************' 791 read (in, *) vr02, av, xlrfq, xphrfq,
type 800 prfq(3) = xlrfq*1.e-03
806 write (6, *)
'*** HERSC and SCHERM cannot be used in',
'the RFQ' 807 write (16, *)
'*** HERSC and SCHERM cannot be used in',
'the RFQ' 810 write (16, *)
'***** beam current: ', beamc,
' mA' 813 write (16, *)
'********************************' 817 write (16, *)
' INIT TOF HAS TO BE PRECEEDED BY GBEAM',
' OR RDBEAM' 820 write (16, *)
'TYPE CODE:NEWF ************************' 829 write (16, *)
' NEW FREQUENCY : ', fh/(2.*pi),
' Hertz' 839 write (16, *)
' TYPE CODE:NREF ***********' 840 read (in, *) dephas, dewref, iref, irefw
842 write (16, *)
'********************************' 849 write (16, *)
' TYPE CODE:SCDYNAC ***********' 855 read (in, *) beamc, sce10
856 if (.not. xiset)
then 858 write (tif, 7001) beamc
859 7001
format (
' XI= ', f9.4)
863 if (iscsp<=1)
write (16, *)
'HERSC method ' 864 if (iscsp==2)
write (16, *)
'SCHERM method ' 865 if (iscsp==3)
write (16, *)
'SCHEFF method ' 867 write (16, *)
'Error in SCDYNAC iscsp: ', iscsp
870 write (16, *)
' Beam current : ', beamc,
' mA' 875 if (iscsp==1) ini = 0
876 if (iscsp<1) ini = -1
881 if (iscsp==2)
read (in, *) idum
887 if (beamc==0.) ichaes = .false.
888 write (16, *)
'****************************' 892 write (16, *)
' TYPE CODE:SCDYNEL ****' 895 write (16, *)
'****************************' 898 write (16, *)
' TYPE CODE:SCPOS(space charge position)****' 900 if (xpsc>=1.) xpsc = .5
901 write (16, *)
'****************************' 906 write (16, *)
' TYPE CODE:TILT *********************' 908 read (in, *) tipha, tix, tiy, shifw, shifp
910 write (16, *)
'****************************' 913 write (16, *)
' TYPE CODE:TILZ *********************' 916 write (16, *)
'****************************' 919 write (16, *)
' TYPE CODE:CHANGREF *********************' 928 write (16, *)
' TYPE CODE: TOF ************' 930 write (16, *)
'****************************' 943 write (16, *)
' TYPE CODE:REJECT*********************' 944 read (in, *) ifw, wdisp, wphas, wx, wy, rlim
946 write (16, 1050) wdisp, wphas, wx, wy, rlim
948 write (16, 1051) wdisp, wphas, wx, wy, rlim
950 1050
format (5x,
' *** BEAM SIZE LIMITS ', /, 4x,
' 1/2 dW/W :', e12.5,
' 1/2 PHASE(DEG) :', e12.5, /, 4x, &
951 ' 1/2 x (cm) :', e12.5,
' 1/2 y(cm) :', e12.5,
' RADIUS (cm) :', e12.5)
952 1051
format (5x,
' *** BEAM SIZE LIMITS ', /, 4x,
'1/2 dW (MeV) :', e12.5,
' 1/2 PHASE(DEG) :', e12.5, /, 4x, &
953 ' 1/2 x (cm) :', e12.5,
' 1/2 y(cm) :', e12.5,
' RADIUS (cm) :', e12.5)
955 wphas = wphas*pi/180.
956 write (16, *)
'****************************' 962 write (16, *)
' TYPE CODE:ZROT*********************' 965 write (16, *)
'****************************' 969 write (16, *)
' TYPE CODE:ALINER*********************' 970 read (in, *) xl, yl, xpl, ypl
972 write (16, *)
'****************************' 975 write (16, *)
' TYPE CODE:ACCEPT*********************' 979 write (16, *)
'****************************' 986 write (16, *)
' TYPE CODE:EMITGR*********************' 989 write (16, *)
'****************************' 993 write (16,
'(a8)') kley
994 read (in,
'(A)') cmnt(1:80)
995 write (16,
'(A)') cmnt(1:80)
998 write (16, *)
'WRBEAM output coordinates of particles' 1001 read (in,
'(A)') wfile
1002 write (16,
'(A)')
'Distribution will be written to ', wfile
1003 read (in, *) irec, iflg
1006 write (16, *)
'****************************' 1007 else if (i==35)
then 1009 write (16, *)
' ENVEL *********************' 1011 write (16, *)
'****************************' 1012 else if (i==36)
then 1014 write (16, *)
' TYPE CODE:CHASE ********************' 1016 write (16, *)
'****************************' 1017 else if (i==37)
then 1020 else if (i==38)
then 1024 write (16, *)
' TYPE CODE:RANDALI*********************' 1028 write (16, *)
'****************************' 1032 read (in, *) xl, yl, xpl, ypl
1034 write (16, *)
'****************************' 1035 else if (i==39)
then 1039 write (16, *)
' TYPE CODE TWQA*********************' 1040 read (in, *) iqrand, qtwist
1042 if (abs(qtwist)<=1.e-20) itwist = .false.
1043 write (16, *)
'****************************' 1044 else if (i==40)
then 1054 read (in, *) iemqesg
1055 if (iemqesg==0) iemgrw = .false.
1056 else if (i==41)
then 1068 write (16, *)
' TYPE CODE MMODE*********************' 1069 read (in, *) ierpf, vphase, vfield
1074 if (ierpf==1)
write (16, 4279) vphase, vfield
1075 4279
format (2x,
'systematic error on phase offset: ', e12.2,
' deg', /, 2x, &
1076 'systematic error on level of field: ', e12.5,
' %')
1077 if (ierpf>1)
write (16, 4290) vphase, vfield
1078 4290
format (2x,
'maximun randon error on phase offset: ', e12.2,
' deg', /, 2x, &
1079 'maximum random error on level of field: ', e12.5,
' %')
1080 vfield = vfield/100.
1081 write (16, *)
'****************************' 1082 else if (i==42)
then 1084 write (16, *)
'TYPE CODE:RFQPTQ ************************' 1112 read (in, 3333) myfile(1:80)
1113 write (16, *)
'RFQ input data file: ', myfile(1:80)
1114 open (27, file=myfile, status=
'unknown')
1115 open (70, file=
'rfq_list.data', status=
'unknown')
1116 open (75, file=
'rfq_coef.data', status=
'unknown')
1117 open (49, file=
'rfq_lost.data', status=
'unknown')
1118 open (89, file=
'rfq_listmid.data', status=
'unknown')
1119 read (in, *) nceltot
1120 read (in, *) tvolt, avolt, fph, pib
1121 write (16, 5279) nceltot, tvolt, avolt
1122 5279
format (
' RFQ number of cells: ', i5, /,
' factor on intervane voltage (reference):', e12.5,
' %', /, &
1123 ' factor on intervane voltage (bunch):', e12.5,
' % ')
1128 write (16, *)
'***** beam current: ', beamc,
' mA' 1130 write (6, *)
'*** HERSC and SCHERM cannot be used in',
'the RFQ' 1131 write (16, *)
'*** HERSC and SCHERM cannot be used in',
'the RFQ' 1137 write (16, *)
'****************************' 1138 else if (i==43)
then 1153 write (16, *)
'TYPE CODE:STRIPPER ***********************' 1154 read (in, *) qs, atms, ths, anp
1156 write (16, *)
'****************************' 1157 else if (i==44)
then 1167 write (16, *)
' TYPE CODE:STEER*********************' 1168 read (in, *) fld, nvf
1169 call steer(fld, nvf)
1170 write (16, *)
'****************************' 1175 dav1(idav, 2) = float(nvf)
1176 dav1(idav, 3) = davtot*10.
1178 else if (i==45)
then 1180 write (16, *)
' TYPE CODE:ZONES*********************' 1183 write (16, *)
'****************************' 1184 else if (i==46)
then 1186 write (16, *)
' TYPE CODE:PROFGR*********************' 1190 read (in, 6620) text
1196 read (in, *) idwdp, iskale
1199 read (in, *) glim(3, 1), glim(3, 2), glim(4, 1), glim(4, 2)
1201 call grcomp(text, iskale)
1202 write (16, *)
'****************************' 1203 else if (i==47)
then 1205 write (16, *)
'*****************************************' 1206 write (16, *)
' SECOND ORDER IN BEAM TRANSPORT**********' 1208 write (16, *)
'*****************************************' 1209 else if (i==48)
then 1211 write (16, *)
' SYNCHRTRON RADIATION IN BENDING MAGNET****' 1213 write (16, *)
'*******************************************' 1214 else if (i==49)
then 1216 write (16, *)
' TYPE CODE:FDRIFT*********************' 1220 read (in, *) xl, npart, imit
1221 dl = xl/float(npart)
1222 write (16, *)
' total drift length : ', xl,
' cm divided in : ', npart,
' drifts of : ', dl,
' cm' 1223 call fdrift(xl, npart, imit)
1224 write (16, *)
'*******************************************' 1225 else if (i==50)
then 1230 write (16, *)
'TYPE CODE FSOLE*****************' 1231 read (in, 3333) myfile(1:80)
1234 iostats = int(ftell(25))
1235 if (iostats==-1)
then 1237 open (25, file=myfile, status=
'unknown')
1238 write (16, *)
'Opening solenoid field file: ', myfile(1:80)
1241 if (ofeldf/=myfile)
then 1242 write (16, *)
'Closing solenoid field file: ', ofelds
1243 write (16, *)
'Opening solenoid field file: ', myfile(1:80)
1245 open (25, file=myfile, status=
'unknown')
1249 read (in, *) bcret, intgr
1250 write (16, 990) intgr
1251 990
format (
'*** SOLENOID WITH ARBITRARY MAGNETIC FIELD ', /, 5x,
'PARTITION IN: ', i4,
' ELEMENTARY SOLENOIDS')
1253 write (16, *)
'********************************' 1254 else if (i==51)
then 1258 write (16, *)
'TYPE CODE EGUN*****************' 1260 read (in, 3333) myfile(1:80)
1261 write (16, *)
'Egun field file: ', myfile(1:80)
1262 open (22, file=myfile, status=
'unknown')
1266 read (in, *) fmult, indp
1267 if (.not. ichaes) indp = 1
1273 write (16, *)
'***** beam current: ', beamc,
' mA' 1275 write (6, *)
'*** HERSC and SCHERM cannot be used',
'with EGUN' 1276 write (16, *)
'*** HERSC and SCHERM cannot be used with',
'with EGUN' 1280 call egun(fmult, indp)
1281 write (16, *)
'*******************************************' 1282 else if (i==52)
then 1286 write (16, *)
' TYPE CODE: COMPRES ********' 1290 write (16, 1890) pib
1292 1890
format (
'*** shift particles inside +/- ', e12.5,
'deg')
1293 write (16, *)
'*******************************************' 1294 else if (i==54)
then 1301 write (16, *)
' TYPE CODE:REFCOG *********************' 1305 write (16, *)
' Synchronous particle is the COG of the',
' bunch' 1311 wcog = wcog + f(7, ijp)
1312 tcog = tcog + f(6, ijp)
1314 wcog = wcog/float(ngood)
1315 tcog = tcog/float(ngood)
1317 bcog = sqrt(gcog*gcog-1.)/gcog
1321 write (16, 5433) obref, otref*fcpi, vref/vl, tref*fcpi, bcog, tcog*fcpi
1322 5433
format (
' old ref. beta: ', e12.5,
' TOF: ', e12.5,
' deg', /,
' new ref. beta: ', e12.5,
' TOF: ', e12.5, &
1323 ' deg', /,
' COG beta: ', e12.5,
' TOF: ', e12.5,
' deg')
1329 write (16, *)
' Synchronous particle and COG of the ',
'bunch are independent' 1333 write (16, *)
' Synchronous particle and COG of the ', &
1334 'bunch are independent, but initially TOF and energy', &
1335 'of the synchronous particle are the ones of the ',
'bunch' 1343 wcog = wcog + f(7, ijp)
1344 tcog = tcog + f(6, ijp)
1346 wcog = wcog/float(ngood)
1347 tcog = tcog/float(ngood)
1349 bcog = sqrt(gcog*gcog-1.)/gcog
1353 if (itvol) ttvols = tref
1356 write (16, 5420) obref, otref*fcpi, vref, tref*fcpi
1357 5420
format (
' old ref. beta: ', e12.5,
' tref: ', e12.5,
' deg', /,
' new ref. beta: ', e12.5,
' tref: ', &
1359 write (16, *)
'old TTVOL (deg): ', ottvols*fcpi
1360 write (16, *)
'new TTVOL (deg): ', ttvols*fcpi
1362 write (16, *)
'****************************' 1363 else if (i==55)
then 1367 write (16, *)
' TYPE CODE:FPART *********************' 1369 write (16, *)
' the particle:', icont,
' is followed' 1370 write (16, *)
'****************************' 1371 else if (i==56)
then 1376 write (16, *)
'TYPE CODE:QUALEC**********' 1377 read (in, *) xlqua, volt, rs
1378 call qelec(volt, xlqua, rs)
1379 write (16, *)
'********************************' 1380 else if (i==57)
then 1386 write (16, *)
'TYPE CODE:QUAFK**********' 1387 read (in, *) ityqu, arg, xlqua, rs
1388 call qfk(ityqu, arg, xlqua, rs)
1389 write (16, *)
'********************************' 1390 else if (i==58)
then 1394 write (16, *)
'TYPE CODE:CAVNUM **********' 1396 write (16, *)
'********************************' 1397 else if (i==59)
then 1404 write (16, *)
'********************************' 1405 else if (i==60)
then 1408 read (in,
'(A)') shortl
1410 else if (i==61)
then 1416 write (16, *)
'TYPE CODE:RFKICK ************************' 1417 read (in, *) pv, pdp, pharm, nvf
1418 plane =
'horizontal' 1419 if (nvf==1) plane =
'vertical ' 1420 write (16, 7779) pv, pdp, plane
1421 7779
format (
' RF Kicker ', /,
' Voltage Factor', e12.5,
' kV*m/m', /,
' RF Phase ', e12.5,
' deg',
' Type: ', &
1424 call rfkick(pv, pdp, pharm, nvf)
1425 write (16, *)
'********************************' 1426 else if (i==62)
then 1428 write (16, *)
'*****************************************' 1429 write (16, *)
' FIRST ORDER IN BEAM TRANSPORT**********' 1431 write (16, *)
'*****************************************' 1432 else if (i==63)
then 1435 write (16, *)
'****************************' 1438 write (16, *)
' DC BEAM SELECTED **********' 1439 else if (iscont==0)
then 1441 write (16, *)
' BUNCHED BEAM SELECTED ********' 1443 write (16, *)
'****************************' 1444 else if (i==64)
then 1447 write (16, *)
'**************************************' 1448 write (16, *)
'* TRACE3D INPUT FILE WILL BE WRITTEN *' 1449 write (16, *)
'**************************************' 1450 else if (i==53)
then 1452 write (16, 100) kle(i)
1459 write (16, 111) kley
1467 open (itout, file=
'for_trace3d.t3d', status=
'unknown')
1468 write (itout,
'(A)') trace3h(1)
1469 write (itout, 1990) kt3t, kt3t, kt3t
1470 1990
format (
' N1= 1, N2= ', i4,
', NEL1= 1, NEL2= ', i4,
', NP1= 1, NP2= ', i4)
1472 write (itout,
'(A)') trace3h(i)
1475 1992
format (
' PQEXT= 2.5, ICHROM= 0, IBS= 0, SMAX= 2.0')
1477 1993
format (
' XM= 15.00, XPM= 50.00, YM= 15.00')
1479 1994
format (
' XMI= 15.00, XPMI= 50.00, XMF= 15.00, XPMF= 25.00')
1481 1995
format (
' DPM= 90.0, DWM= 50.00, DPP= 90.00')
1483 1996
format (
' DPMI= 90.0, DPMF= 35.00, DWMI= 50.0, DWMF= 200.0')
1496 if (tif(12:13)==
' 1' .and. tifb(12:13)==
' 1')
then 1497 read (tif(28:50), *) trdrift
1498 if (trdrift<0.)
then 1499 read (tifb(28:50), *) trdrifb
1500 if (trdrifb>0.)
then 1501 aver = (trdrifb+trdrift)/2.
1505 write (fdrft, 555) trdrift
1508 write (fdrft, 555) trdrifb
1514 else if (tif(12:13)==
' 1' .and. tifa(12:13)==
' 1')
then 1515 read (tif(28:50), *) trdrift
1516 if (trdrift<0.)
then 1517 read (tifa(28:50), *) trdrifa
1518 if (trdrifa>0.)
then 1519 aver = (trdrifa+trdrift)/2.
1523 write (fdrft, 555) trdrift
1525 write (fdrft, 555) trdrifa
1534 write (itout,
'(A)') trace3t(k)
1536 write (itout,
'(A)')
' $END' 1540 call cpu_time(exfin)
1541 exfin = exfin - exstrt
1547 if (iitime(1:2)==
'01') text(5:7) =
'Jan' 1548 if (iitime(1:2)==
'02') text(5:7) =
'Feb' 1549 if (iitime(1:2)==
'03') text(5:7) =
'Mar' 1550 if (iitime(1:2)==
'04') text(5:7) =
'Apr' 1551 if (iitime(1:2)==
'05') text(5:7) =
'May' 1552 if (iitime(1:2)==
'06') text(5:7) =
'Jun' 1553 if (iitime(1:2)==
'07') text(5:7) =
'Jul' 1554 if (iitime(1:2)==
'08') text(5:7) =
'Aug' 1555 if (iitime(1:2)==
'09') text(5:7) =
'Sep' 1556 if (iitime(1:2)==
'10') text(5:7) =
'Oct' 1557 if (iitime(1:2)==
'11') text(5:7) =
'Nov' 1558 if (iitime(1:2)==
'12') text(5:7) =
'Dec' 1560 text(9:10) = iitime(4:5)
1562 text(14:15) = iitime(7:8)
1563 text(16:19) =
' at ' 1564 text(20:27) = iitime(10:17)
1566 text(1:11) = iitime(1:11)
1567 text(12:15) = iitime(21:24)
1568 text(16:19) =
' at ' 1569 text(20:27) = iitime(12:19)
1571 write (12, *)
'Stopped on ', text(1:27)
1572 write (16, *)
'Stopped on ', text(1:27)
1573 write (6,
'(A11,A27)')
'Stopped on ', text(1:27)
1574 write (6,
'(A12,F14.6,A4)')
'Executed in ', exfin,
' sec' 1607 111
format (
'STOP ON KEY: ', a8,
' (invalid key)')
1608 100
format (/, 40x,
' STOP on key : ', a8, //)
1609 101
format (
'*******************************************************',
'*****************')
1615 subroutine mytime(iitime)
1616 implicit real *8(a-h, o-z)
1621 iitime = ctime(inttim)
1643 implicit real *8(a-h, o-z)
1644 parameter(maxcell1=3000)
1645 common /tapes/in, ifile, meta
1646 common /dyn/tref, vref
1647 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
1648 common /consta/vl, pi, xmat, rpel, qst
1649 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
1650 common /itvole/itvol, imamin
1651 common /tofev/ttvols
1652 logical itvol, imamin
1656 read (in, *) indic, icor
1660 write (16, 10) ttvols*fcpi, davtot, tref*fcpi
1663 write (16, *)
'time of flight passive ' 1665 10
format (
' ** time of flight activated at: ', e12.5,
' deg at position: ', e12.5,
' cm in the lattice', /, 3x, &
1666 'tof of the reference: ', e12.5,
' deg')
1668 if (itvol .and. icor/=0) imamin = .true.
1669 if (imamin)
write (16, *)
' Adjustments on phase offset of acc. elements' 1670 if (.not. imamin)
write (16, *)
' No adjustments on phase offset' 1672 end subroutine rmami 1707 implicit real *8(a-h, o-z)
1708 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
1709 common /faisc/f(10, iptsz), imax, ngood
1710 common /mcs/imcs, ncstat, cstat(20)
1715 1
if (ngood1>=k)
go to 5
1716 if (f(8,ngood1+1)==1.)
go to 4
1719 f(j, ngood1+1) = f(j, k)
1724 4 ngood1 = ngood1 + 1
1731 ratei = float(imax)/float(ngood)
1739 if (f(9,j)==cstat(k))
then 1745 cstat(ncstat) = f(9, j)
1748 write (16, *)
'Number of charge states after shuffle: ', ncstat
1749 write (16, *)
'Charge states: ', (cstat(j), j=1, ncstat)
1751 if (ncstat>1) imcs = 1
1755 write (16, *)
'Less than 10 particles left, statistics too low' 1757 write (6, *)
'Less than 10 particles left, statistics too low' 1766 function xitl0(gami, gams, betr, saphi, qqc)
1767 implicit real *8(a-h, o-z)
1768 common /consta/vl, pi, xmat, rpel, qst
1769 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
1770 common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
1774 beti = sqrt(1.-1./(gami*gami))
1775 bets = sqrt(1.-1./(gams*gams))
1779 tilta2 = phslip/(2.*eqvl)
1780 pavph = 1./10.*(xk1-xk2)*eqvl + (xk1-xkm)*asdl
1781 xkc1 = -fh0/(beti**3*gami**3)
1782 xkc2 = -fh0/(bets**3*gams**3)
1784 phit10 = saphi - phslip/2. + pavph
1785 daz0 = cos(phit10)*tilta2
1786 dbz0 = sin(phit10)*tilta2
1787 dgz0 = cgi*(tk*daz0-sk*dbz0)
1788 dgz0 = dgz0/sin(phslip/2.)
1790 phit11 = saphi + phslip/2. + pavph
1791 daz1 = cos(phit11)*tilta2
1792 dbz1 = sin(phit11)*tilta2
1793 dgz1 = cgi*(tk*daz1-sk*dbz1)
1794 dgz1 = dgz1/sin(phslip/2.)
1796 pavph = 1./10.*(xk1-xk2)*eqvl + (xk1-xkm)*asdl
1797 pavph = pavph + (xkp1+xkp2)*eqvl**2/120.
1803 ccl1 = -(4.*xk22+6.*xk11)/(eqvl**2)
1804 ccl2 = -(3./2.*xkp1-xkp2/2.)/eqvl
1806 ddl1 = (7.*xk22+8.*xk11)/(eqvl**3)
1807 ddl2 = (3./2.*xkp1-xkp2)/(eqvl**2)
1809 eel1 = -(3.*xk22+3.*xk11)/(eqvl**4)
1810 eel2 = -(xkp1/2.-xkp2/2.)/(eqvl**3)
1812 phit0 = saphi + pavph
1813 git = cgi*(tk*cos(phit0)-sk*sin(phit0))
1823 function xitl2(gami, gams, betr, saphi, qqc)
1824 implicit real *8(a-h, o-z)
1825 common /consta/vl, pi, xmat, rpel, qst
1826 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
1827 common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
1828 dimension h(8), t(8)
1829 data h/.101228536, .222381034, .313706646, .362683783, .362683783, .313706646, .222381034, .101228536/
1830 data t/ -.960289856, -.796666477, -.525532409, -.183434642, .183434642, .525532409, .796666477, .960289856/
1835 beti = sqrt(1.-1./(gami*gami))
1836 bets = sqrt(1.-1./(gams*gams))
1840 tilta2 = phslip/(2.*eqvl)
1842 xcc = eqvl*(1.+t(i))/2.
1843 phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
1844 git = cgi*(tk*cos(phit0)-sk*sin(phit0))
1845 gi = gami + git*sin(xcc*tilta2)/sin(phslip/2.)
1846 bi = sqrt(1.-1./(gi*gi))
1847 phit1 = phit0 + xcc*phslip/(2.*eqvl)
1848 daz = cos(phit1)*tilta2
1849 dbz = sin(phit1)*tilta2
1850 dgz = cgi*(tk*daz-sk*dbz)
1851 dgz = dgz/sin(phslip/2.)
1866 function xitl3(gami, gams, betr, nit, saphi, qqc)
1867 implicit real *8(a-h, o-z)
1868 common /consta/vl, pi, xmat, rpel, qst
1869 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
1870 common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
1871 common /midgap/enmil, vapmi
1872 common /gaus13/h(13), t(13)
1878 beti = sqrt(1.-1./(gami*gami))
1879 bets = sqrt(1.-1./(gams*gams))
1884 tilta2 = phslip/(2.*eqvl)
1886 xcc = eqvl*(1.+t(i))/2.
1887 phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
1888 git = cgi*(tk*cos(phit0)-sk*sin(phit0))
1889 gi = gami + git*sin(xcc*tilta2)/sin(phslip/2.)
1890 bi = sqrt(1.-1./(gi*gi))
1891 phit1 = phit0 + xcc*phslip/(2.*eqvl)
1892 daz = cos(phit1)*tilta2
1893 dbz = sin(phit1)*tilta2
1894 dgz = cgi*(tk*daz-sk*dbz)
1895 dgz = dgz/sin(phslip/2.)
1901 if (nit==3 .and. i==7)
then 1903 enmil = xmat*(gi-1.)
1904 vapmi = (xk11*asdl+saphi+xkm*xcc1+aa*xcc+bb*xcc*xcc+cc*xcc**3+dd*xcc**4+ee*xcc**5)*180./pi
1916 subroutine xtypl2(gami, saphi, qsc, dcg)
1917 implicit real *8(a-h, o-z)
1918 common /consta/vl, pi, xmat, rpel, qst
1919 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
1920 common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
1921 common /thad2/h0aki, h0akim, h0akm, h0bki, h0bkim, h0bkm, h1aki, h1akim, h1akm, h1bki, h1bkim, h1bkm
1922 common /gaus17/h1(17), t1(17)
1927 beti = sqrt(1.-1./gam2)
1945 tilta2 = phslip/(2.*eqvl)
1946 cgam10 = ((gami*gami-1.)**3)/(fh0*fh0)
1947 dgam10 = gami*((gami*gami-1.)**2)/(fh0*fh0)
1948 phcrtk = (t1k*sk-s1k*tk)/(tk*tk+sk*sk)
1949 dphc1 = (t2k*sk-s2k*tk)/(tk*tk+sk*sk)
1950 dphc2 = (t1k*tk+s1k*sk)*(t1k*sk-s1k*tk)/((tk*tk+sk*sk)**2)
1951 dphcrtk = dphc1 - 2.*dphc2
1956 xcc = eqvl*(1.+h1(i))/2.
1958 if (xcc1>dcg)
go to 200
1959 phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
1961 if (phslip/=0.)
then 1962 git = cgi*sqcttf*cos(phit0-pcrest)/phslip
1963 gis = sin(xcc*tilta2)
1965 git = cgi*sqcttf*cos(phit0-pcrest)
1970 bi = sqrt(1.-1./(gi*gi))
1972 phit0k = -dtilk*(1.-xcc/eqvl)/2.
1974 if (phslip/=0.)
then 1975 gic = cos(xcc*tilta2)
1976 gak1 = dtilk*cos(phit0-pcrest)*gis/(phslip*phslip)
1977 gak2 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)/phslip
1978 gak3 = dtilk*cos(phit0-pcrest)*xcc*gic/(2.*phslip*eqvl)
1979 gak = cgi*sqcttf*(-gak1-gak2+gak3)
1981 gak1 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)
1982 gak = -cgi*sqcttf*gak1
1986 dgak = (gak-gakm1)/(gi-gait)*gak
1993 phit1 = phit0 + xcc*phslip/(2.*eqvl)
1994 phtz0 = (xcc/eqvl-.5)*dtilk
1996 phcrz0 = (phtz0-phcrtk)
1998 haki1 = sqcttf*cos(phit1-pcrest)/((gi*gi-1.)**2.5)
1999 haki2 = sqcttf*cos(phit1-pcrest)*gi/((gi*gi-1.)**2.5)
2000 haki3 = sqcttf*cos(phit1-pcrest)*gi*gi/((gi*gi-1.)**3.5)
2002 h0aki = h0aki + t1(i)*cgam10*(-3.*haki1+15*haki3) - t1(i)*dgam10*9.*haki2
2004 h1aki = h1aki + t1(i)*cgam10*xcc1*(-3.*haki1+15.*haki3) - t1(i)*dgam10*9.*haki2*xcc1
2006 hakim1 = sqcttf*cos(phit1-pcrest)*gak/((gi*gi-1.)**2.5)
2007 hakim2 = sqcttf*cos(phit1-pcrest)*gi*gi*gak/((gi*gi-1.)**3.5)
2009 hakim3 = sqcttf*sin(phit1-pcrest)*gi/((gi*gi-1.)**2.5)
2011 h0akim = h0akim + t1(i)*sqrt(cgam10)*(6.*hakim1-30.*hakim2-3.*phcrz0*hakim3)
2013 h1akim = h1akim + t1(i)*sqrt(cgam10)*(6.*hakim1-30.*hakim2-3.*phcrz0*hakim3)*xcc1
2015 hakm1 = sqcttf*cos(phit1-pcrest)*gak*gak/((gi*gi-1.)**2.5)
2016 hakm2 = sqcttf*cos(phit1-pcrest)*dgak*gi/((gi*gi-1.)**2.5)
2017 hakm3 = sqcttf*cos(phit1-pcrest)*gak*gak*gi*gi/((gi*gi-1.)**3.5)
2018 hakm4 = sqcttf*sin(phit1-pcrest)*gak*gi/((gi*gi-1.)**2.5)
2019 hakm5 = sqcttf*cos(phit1-pcrest)/((gi*gi-1.)**1.5)
2020 hakm6 = sqcttf*sin(phit1-pcrest)/((gi*gi-1.)**1.5)
2022 h0akm = h0akm + t1(i)*(-3.*hakm1-3.*hakm2+15.*hakm3+3.*phcrz0*hakm4-phcrz0*phcrz0*hakm5+dphcrtk*hakm6)
2024 h1akm = h1akm + t1(i)*xcc1*(-3.*hakm1-3.*hakm2+15.*hakm3+3.*phcrz0*hakm4-phcrz0*phcrz0*hakm5+dphcrtk*hakm6)
2027 hbki1 = sqcttf*sin(phit1-pcrest)/((gi*gi-1.)**2.5)
2028 hbki2 = sqcttf*sin(phit1-pcrest)*gi/((gi*gi-1.)**2.5)
2029 hbki3 = sqcttf*sin(phit1-pcrest)*gi*gi/((gi*gi-1.)**3.5)
2031 h0bki = h0bki + t1(i)*cgam10*(-3.*hbki1+15.*hbki3) - t1(i)*dgam10*9.*hbki2
2033 h1bki = h1bki + t1(i)*cgam10*xcc1*(-3.*hbki1+15.*hbki3) - t1(i)*dgam10*9.*hbki2*xcc1
2035 hbkim1 = sqcttf*sin(phit1-pcrest)*gak/((gi*gi-1.)**2.5)
2036 hbkim2 = sqcttf*sin(phit1-pcrest)*gi*gi*gak/((gi*gi-1.)**3.5)
2038 hbkim3 = sqcttf*cos(phit1-pcrest)*gi/((gi*gi-1.)**2.5)
2040 h0bkim = h0bkim + t1(i)*sqrt(cgam10)*(6.*hakim1-30.*hakim2+3.*phcrz0*hakim3)
2042 h1bkim = h1bkim + t1(i)*sqrt(cgam10)*(6.*hakim1-30.*hakim2+3.*phcrz0*hakim3)*xcc1
2044 hbkm1 = sqcttf*sin(phit1-pcrest)*gak*gak/((gi*gi-1.)**2.5)
2045 hbkm2 = sqcttf*sin(phit1-pcrest)*dgak*gi/((gi*gi-1.)**2.5)
2046 hbkm3 = sqcttf*sin(phit1-pcrest)*gak*gak*gi*gi/((gi*gi-1.)**3.5)
2047 hbkm4 = sqcttf*cos(phit1-pcrest)*gak*gi/((gi*gi-1.)**2.5)
2048 hbkm5 = sqcttf*sin(phit1-pcrest)/((gi*gi-1.)**1.5)
2049 hbkm6 = sqcttf*cos(phit1-pcrest)/((gi*gi-1.)**1.5)
2051 h0bkm = h0bkm + t1(i)*(-3.*hbkm1-3.*hbkm2+15.*hbkm3-3.*phcrz0*hbkm4-phcrz0*phcrz0*hbkm5-dphcrtk*hbkm6)
2053 h1bkm = h1bkm + t1(i)*xcc1*(-3.*hbkm1-3.*hbkm2+15.*hbkm3-3.*phcrz0*hbkm4-phcrz0*phcrz0*hbkm5-dphcrtk*hbkm6)
2057 h0aki = h0aki/2.*eqvl
2058 h0akim = h0akim/2.*eqvl
2059 h0akm = h0akm/2.*eqvl
2060 h1aki = h1aki/2.*eqvl
2061 h1akim = h1akim/2.*eqvl
2062 h1akm = h1akm/2.*eqvl
2064 h0bki = h0bki/2.*eqvl
2065 h0bkim = h0bkim/2.*eqvl
2066 h0bkm = h0bkm/2.*eqvl
2067 h1bki = h1bki/2.*eqvl
2068 h1bkim = h1bkim/2.*eqvl
2069 h1bkm = h1bkm/2.*eqvl
2080 subroutine xtyplp1(gami, saphi, qsc, dcg)
2081 implicit real *8(a-h, o-z)
2082 common /consta/vl, pi, xmat, rpel, qst
2083 common /jacob/gaks, gaps
2084 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
2085 common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
2086 common /typlp1/yh1p1, yh2p1, hapi, hbpi
2087 common /typlp2/happi, hbppi
2088 common /gaus17/h1(17), t1(17)
2093 beti = sqrt(1.-1./gam2)
2104 tilta2 = phslip/(2.*eqvl)
2105 if (phslip/=0.) desy = phslip/sin(phslip/2.)
2106 if (phslip==0.) desy = 2.
2108 xcc = eqvl*(1.+h1(i))/2.
2110 if (xcc1>dcg)
go to 200
2111 phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
2113 if (phslip/=0.)
then 2114 git = cgi*sqcttf*cos(phit0-pcrest)/phslip
2115 gis = sin(xcc*tilta2)
2117 git = cgi*sqcttf*cos(phit0-pcrest)
2121 bi = sqrt(1.-1./(gi*gi))
2123 if (phslip/=0.)
then 2124 gap = -cgi*sqcttf*sin(phit0-pcrest)*gis/phslip
2128 gap = sin(phit0-pcrest)*gis
2132 if (i==17) gaps =
gap 2134 if (phslip/=0.)
then 2135 dgap = -cgi*sqcttf*cos(phit0-pcrest)*gis/phslip
2137 dgap = cos(phit0-pcrest)*gis
2138 dgap = -cgi*sqcttf*dgap
2141 xint = 1./(bi*bi*bi*gi*gi*gi)
2142 phit1 = phit0 + xcc*phslip/(2.*eqvl)
2143 phtz0 = (xcc/eqvl-.5)*dtilk
2145 dha01 = sqcttf*cos(phit1-pcrest)*gi*
gap/((gi*gi-1.)**2.5)
2148 yh1p1 = yh1p1 + t1(i)*xcc1*(-6.*dha01-2.*dha02)
2150 dhb01 = sqcttf*sin(phit1-pcrest)*gi*
gap/((gi*gi-1.)**2.5)
2153 yh2p1 = yh2p1 + t1(i)*xcc1*(-6.*dhb01+2.*dhb02)
2155 hapi1 = sqcttf*cos(phit1-pcrest)*
gap*
gap/((gi*gi-1.)**2.5)
2156 hapi2 = sqcttf*cos(phit1-pcrest)*gi*dgap/((gi*gi-1.)**2.5)
2157 hapi3 = sqcttf*cos(phit1-pcrest)*gi*gi*
gap*
gap/((gi*gi-1.)**3.5)
2159 hapi = hapi + t1(i)*xcc1*(-3.*hapi1-3.*hapi2+15.*hapi3)
2161 happi1 = sqcttf*cos(phit1-pcrest)*
gap*dgap/((gi*gi-1.)**2.5)
2162 happi2 = sqcttf*cos(phit1-pcrest)*
gap*
gap*
gap*gi/((gi*gi-1.)**3.5)
2163 happi3 = sqcttf*cos(phit1-pcrest)*
gap*dgap/((gi*gi-1.)**2.5)
2164 happi4 = sqcttf*cos(phit1-pcrest)*gi*ddgap/((gi*gi-1.)**2.5)
2165 happi5 = sqcttf*cos(phit1-pcrest)*gi*gi*
gap*dgap/((gi*gi-1.)**3.5)
2166 happi6 = sqcttf*cos(phit1-pcrest)*gi*
gap**3/((gi*gi-1.)**3.5)
2167 happi7 = sqcttf*cos(phit1-pcrest)*gi*gi*dgap*
gap/((gi*gi-1.)**3.5)
2168 happi8 = sqcttf*cos(phit1-pcrest)*gi*gi*gi*
gap*
gap*
gap/((gi*gi-1.)**4.5)
2170 happi = happi + t1(i)*xcc1*(-6.*happi1+15.*happi2-3.*happi3-3.*happi4+15.*happi5+30.*happi6+30.*happi7-105.* &
2174 hbpi1 = sqcttf*sin(phit1-pcrest)*
gap*
gap/((gi*gi-1.)**2.5)
2175 hbpi2 = sqcttf*sin(phit1-pcrest)*gi*dgap/((gi*gi-1.)**2.5)
2176 hbpi3 = sqcttf*sin(phit1-pcrest)*gi*gi*
gap*
gap/((gi*gi-1.)**3.5)
2178 hbpi = hbpi + t1(i)*xcc1*(-3.*hbpi1-3.*hbpi2+15.*hbpi3)
2180 hbppi1 = sqcttf*sin(phit1-pcrest)*
gap*dgap/((gi*gi-1.)**2.5)
2181 hbppi2 = sqcttf*sin(phit1-pcrest)*
gap*
gap*
gap*gi/((gi*gi-1.)**3.5)
2182 hbppi3 = sqcttf*sin(phit1-pcrest)*
gap*dgap/((gi*gi-1.)**2.5)
2183 hbppi4 = sqcttf*sin(phit1-pcrest)*gi*ddgap/((gi*gi-1.)**2.5)
2184 hbppi5 = sqcttf*sin(phit1-pcrest)*gi*gi*
gap*dgap/((gi*gi-1.)**3.5)
2185 hbppi6 = sqcttf*sin(phit1-pcrest)*gi*
gap**3/((gi*gi-1.)**3.5)
2186 hbppi7 = sqcttf*sin(phit1-pcrest)*gi*gi*dgap*
gap/((gi*gi-1.)**3.5)
2187 hbppi8 = sqcttf*sin(phit1-pcrest)*gi*gi*gi*
gap*
gap*
gap/((gi*gi-1.)**4.5)
2189 hbppi = happi + t1(i)*xcc1*(-6.*hbppi1+15.*hbppi2-3.*hbppi3-3.*hbppi4+15.*hbppi5+30.*hbppi6+30.*hbppi7-105.* &
2194 yh1p1 = yh1p1/2.*eqvl
2196 happi = happi/2.*eqvl
2198 yh2p1 = yh2p1/2.*eqvl
2200 hbppi = hbppi/2.*eqvl
2210 subroutine xtylpk(gami, saphi, qsc, dcg)
2211 implicit real *8(a-h, o-z)
2212 common /consta/vl, pi, xmat, rpel, qst
2213 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
2214 common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
2215 common /typlpk/yh10pk, yh11pk, yh20pk, yh21pk
2216 common /gaus17/h1(17), t1(17)
2221 beti = sqrt(1.-1./gam2)
2230 tilta2 = phslip/(2.*eqvl)
2231 if (phslip/=0.) desy = phslip/sin(phslip/2.)
2232 if (phslip==0.) desy = 2.
2233 cgam10 = ((gami*gami-1.)**1.5)/fh0
2234 phcrtk = (t1k*sk-s1k*tk)/(tk*tk+sk*sk)
2236 xcc = eqvl*(1.+h1(i))/2.
2238 if (xcc1>dcg)
go to 200
2239 phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
2241 if (phslip/=0.)
then 2242 git = cgi*sqcttf*cos(phit0-pcrest)/phslip
2243 gis = sin(xcc*tilta2)
2245 git = cgi*sqcttf*cos(phit0-pcrest)
2249 bi = sqrt(1.-1./(gi*gi))
2251 if (phslip/=0.)
then 2252 gap = -cgi*sqcttf*sin(phit0-pcrest)*gis/phslip
2254 gap = sin(phit0-pcrest)*gis
2258 phit0k = -dtilk*(1.-xcc/eqvl)/2.
2259 if (phslip/=0.)
then 2260 gic = cos(xcc*tilta2)
2261 gak1 = dtilk*cos(phit0-pcrest)*gis/(phslip*phslip)
2262 gak2 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)/phslip
2263 gak3 = dtilk*cos(phit0-pcrest)*xcc*gic/(2.*phslip*eqvl)
2264 gak = cgi*sqcttf*(-gak1-gak2+gak3)
2266 gak1 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)
2267 gak = -cgi*sqcttf*gak1
2270 if (phslip/=0.)
then 2271 gic = cos(xcc*tilta2)
2272 gakp1 = dtilk*sin(phit0-pcrest)*gis/(phslip*phslip)
2273 gakp2 = cos(phit0-pcrest)*gis*(phit0k-phcrtk)/phslip
2274 gakp3 = dtilk*sin(phit0-pcrest)*xcc*gic/(2.*phslip*eqvl)
2275 gakp = cgi*sqcttf*(gakp1-gakp2-gakp3)
2277 gakp1 = cos(phit0-pcrest)*gis*(phit0k-phcrtk)
2278 gakp = -cgi*sqcttf*gakp1
2281 xint = 1./(bi*bi*bi*gi*gi*gi)
2282 phit1 = phit0 + xcc*phslip/(2.*eqvl)
2284 dha01 = sqcttf*cos(phit1-pcrest)*
gap/((gi*gi-1.)**2.5)
2285 dha02 = sqcttf*cos(phit1-pcrest)*gi*gi*
gap/((gi*gi-1.)**3.5)
2286 dhb01 = sqcttf*sin(phit1-pcrest)*
gap/((gi*gi-1.)**2.5)
2287 dhb02 = sqcttf*sin(phit1-pcrest)*gi*gi*
gap/((gi*gi-1.)**3.5)
2289 yh10pk = yh10pk + t1(i)*xcc1*cgam10*(3.*dha01-15.*dha02)
2290 yh20pk = yh20pk + t1(i)*xcc1*cgam10*(3.*dhb01-15.*dhb02)
2292 hapi1 = sqcttf*cos(phit1-pcrest)*
gap*gak/((gi*gi-1.)**2.5)
2293 hapi2 = sqcttf*cos(phit1-pcrest)*gi*gakp/((gi*gi-1.)**2.5)
2294 hapi3 = sqcttf*cos(phit1-pcrest)*gi*gi*
gap*gak/((gi*gi-1.)**3.5)
2296 yh11pk = yh11pk + t1(i)*xcc1*(-3.*hapi1-3.*hapi2+15.*hapi3)
2298 hbpi1 = sqcttf*sin(phit1-pcrest)*
gap*gak/((gi*gi-1.)**2.5)
2299 hbpi2 = sqcttf*sin(phit1-pcrest)*gi*gakp/((gi*gi-1.)**2.5)
2300 hbpi3 = sqcttf*sin(phit1-pcrest)*gi*gi*
gap*gak/((gi*gi-1.)**3.5)
2302 yh21pk = yh21pk + t1(i)*xcc1*(-3.*hbpi1-3.*hbpi2+15.*hbpi3)
2306 yh10pk = yh10pk/2.*eqvl
2307 yh11pk = yh11pk/2.*eqvl
2309 yh20pk = yh20pk/2.*eqvl
2310 yh21pk = yh21pk/2.*eqvl
2318 subroutine xtypj(gami, saphi, qsc, dcg)
2319 implicit real *8(a-h, o-z)
2320 common /consta/vl, pi, xmat, rpel, qst
2321 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
2322 common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
2323 common /typj/yfsk0, yfsk1, yfsk2, yfsp0, yfsp1, yfsp2, yfskc0, yfskc1, yfskc2, yfsck0, yfsck1, yfsck2, yfscp0, &
2324 yfscp1, yfscp2, yfs0, yfs1, yfs2
2325 common /gaus17/h1(17), t1(17)
2330 beti = sqrt(1.-1./gam2)
2351 tilta2 = phslip/(2.*eqvl)
2352 if (phslip/=0.) desy = phslip/sin(phslip/2.)
2353 if (phslip==0.) desy = 2.
2354 cgam10 = ((gami*gami-1.)**1.5)/fh0
2355 phcrtk = (t1k*sk-s1k*tk)/(tk*tk+sk*sk)
2357 xcc = eqvl*(1.+h1(i))/2.
2359 if (xcc1>dcg)
go to 200
2360 phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
2362 if (phslip/=0.)
then 2363 git = cgi*sqcttf*cos(phit0-pcrest)/phslip
2364 gis = sin(xcc*tilta2)
2366 git = cgi*sqcttf*cos(phit0-pcrest)
2370 bi = sqrt(1.-1./(gi*gi))
2372 phit0k = -dtilk*(1.-xcc/eqvl)/2.
2373 if (phslip/=0.)
then 2374 gic = cos(xcc*tilta2)
2375 gak1 = dtilk*cos(phit0-pcrest)*gis/(phslip*phslip)
2376 gak2 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)/phslip
2377 gak3 = dtilk*cos(phit0-pcrest)*xcc*gic/(2.*phslip*eqvl)
2378 gak = cgi*sqcttf*(-gak1-gak2+gak3)
2380 gak1 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)
2381 gak = -cgi*sqcttf*gak1
2383 phit1 = phit0 + xcc*phslip/(2.*eqvl)
2384 phtz0 = (xcc/eqvl-.5)*dtilk
2385 xint = (gi*gi+2.)/((gi*gi-1.)**2)
2386 xfk1 = 2.*gi*(1.-2.*(gi*gi+2.)/(gi*gi-1.))/((gi*gi-1.)**2)
2387 ha0 = cos(phit1-pcrest)
2388 hb0 = sin(phit1-pcrest)
2390 yfs0 = yfs0 + t1(i)*ha0*ha0*xint
2391 yfskc0 = yfskc0 - t1(i)*ha0*ha0*xfk1*cgam10
2392 yfsk0 = yfsk0 + t1(i)*ha0*ha0*xfk1*gak
2393 yfsck0 = yfsck0 - 2.*t1(i)*ha0*hb0*xint*(phtz0-phcrtk)
2395 yfs1 = yfs1 + t1(i)*ha0*ha0*xint*xcc
2396 yfskc1 = yfskc1 - t1(i)*ha0*ha0*xfk1*cgam10*xcc
2397 yfsk1 = yfsk1 + t1(i)*ha0*ha0*xfk1*gak*xcc
2398 yfsck1 = yfsck1 - 2.*t1(i)*ha0*hb0*xint*(phtz0-phcrtk)*xcc
2400 yfs2 = yfs2 + t1(i)*ha0*ha0*xint*xcc*xcc
2401 yfskc2 = yfskc2 - t1(i)*ha0*ha0*xfk1*cgam10*xcc*xcc
2402 yfsk2 = yfsk2 + t1(i)*ha0*ha0*xfk1*gak*xcc*xcc
2403 yfsck2 = yfsck2 - 2.*t1(i)*ha0*hb0*xint*(phtz0-phcrtk)*xcc*xcc
2405 if (phslip/=0.)
then 2406 gap = -cgi*sqcttf*sin(phit0-pcrest)*gis/phslip
2408 gap = sin(phit0-pcrest)*gis
2412 yfsp0 = yfsp0 + t1(i)*xfk1*
gap*ha0*ha0
2413 yfscp0 = yfscp0 - 2.*t1(i)*xint*ha0*hb0
2415 yfsp1 = yfsp1 + t1(i)*xfk1*
gap*ha0*ha0*xcc
2416 yfscp1 = yfscp1 - 2.*t1(i)*xint*ha0*hb0*xcc
2418 yfsp2 = yfsp2 + t1(i)*xfk1*
gap*ha0*ha0*xcc*xcc
2419 yfscp2 = yfscp2 - 2.*t1(i)*xint*ha0*hb0*xcc*xcc
2426 yfskc0 = yfskc0/2.*eqvl
2427 yfskc1 = yfskc1/2.*eqvl
2428 yfskc2 = yfskc2/2.*eqvl
2429 yfsk0 = yfsk0/2.*eqvl
2430 yfsk1 = yfsk1/2.*eqvl
2431 yfsk2 = yfsk2/2.*eqvl
2432 yfsck0 = yfsck0/2.*eqvl
2433 yfsck1 = yfsck1/2.*eqvl
2434 yfsck2 = yfsck2/2.*eqvl
2435 yfscp0 = yfscp0/2.*eqvl
2436 yfscp1 = yfscp1/2.*eqvl
2437 yfscp2 = yfscp2/2.*eqvl
2438 yfsp0 = yfsp0/2.*eqvl
2439 yfsp1 = yfsp1/2.*eqvl
2440 yfsp2 = yfsp2/2.*eqvl
2442 end subroutine xtypj 2448 subroutine xtypm(gami, saphi, qsc, dcg)
2449 implicit real *8(a-h, o-z)
2450 common /consta/vl, pi, xmat, rpel, qst
2451 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
2452 common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
2453 common /typm/ynsk0, ynsk1, ynsk2, ynsp0, ynsp1, ynsp2, ynsk0c, ynsk1c, ynsk2c, yns0, yns1, yns2
2454 common /gaus17/h1(17), t1(17)
2472 beti = sqrt(1.-1./gam2)
2474 tilta2 = phslip/(2.*eqvl)
2475 if (phslip/=0.) desy = phslip/sin(phslip/2.)
2476 if (phslip==0.) desy = 2.
2477 cgam10 = ((gami*gami-1.)**1.5)/fh0
2478 phcrtk = (t1k*sk-s1k*tk)/(tk*tk+sk*sk)
2480 xcc = eqvl*(1.+h1(i))/2.
2482 if (xcc1>dcg)
go to 200
2483 phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
2485 if (phslip/=0.)
then 2486 git = cgi*sqcttf*cos(phit0-pcrest)/phslip
2487 gis = sin(xcc*tilta2)
2489 git = cgi*sqcttf*cos(phit0-pcrest)
2493 bi = sqrt(1.-1./(gi*gi))
2495 phit0k = -dtilk*(1.-xcc/eqvl)/2.
2496 if (phslip/=0.)
then 2497 gic = cos(xcc*tilta2)
2498 gak1 = dtilk*cos(phit0-pcrest)*gis/(phslip*phslip)
2499 gak2 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)/phslip
2500 gak3 = dtilk*cos(phit0-pcrest)*xcc*gic/(2.*phslip*eqvl)
2501 gak = cgi*sqcttf*(-gak1-gak2+gak3)
2503 gak1 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)
2504 gak = -cgi*sqcttf*gak1
2506 xint = (gi*gi+2.)/((gi*gi-1.)**2)
2507 xnk1 = 2.*gi*(1.-2.*(gi*gi+2.)/(gi*gi-1.))/((gi*gi-1.)**2)
2509 yns0 = yns0 + t1(i)*xint
2510 ynsk0c = ynsk0c - t1(i)*xnk1*cgam10
2511 ynsk0 = ynsk0 + t1(i)*xnk1*gak
2513 yns1 = yns1 + t1(i)*xint*xcc
2514 ynsk1c = ynsk1c - t1(i)*xnk1*cgam10*xcc
2515 ynsk1 = ynsk1 + t1(i)*xnk1*gak*xcc
2517 yns2 = yns2 + t1(i)*xint*xcc*xcc
2518 ynsk2c = ynsk2c - t1(i)*xnk1*cgam10*xcc*xcc
2519 ynsk2 = ynsk2 + t1(i)*xnk1*gak*xcc*xcc
2521 if (phslip/=0.)
then 2522 gap = -cgi*sqcttf*sin(phit0-pcrest)*gis/phslip
2524 gap = sin(phit0-pcrest)*gis
2527 ynsp0 = ynsp0 + t1(i)*xnk1*
gap 2528 ynsp1 = ynsp1 + t1(i)*xnk1*
gap*xcc
2529 ynsp2 = ynsp2 + t1(i)*xnk1*
gap*xcc*xcc
2535 ynsk0c = ynsk0c/2.*eqvl
2536 ynsk1c = ynsk1c/2.*eqvl
2537 ynsk2c = ynsk2c/2.*eqvl
2538 ynsk0 = ynsk0/2.*eqvl
2539 ynsk1 = ynsk1/2.*eqvl
2540 ynsk2 = ynsk2/2.*eqvl
2541 ynsp0 = ynsp0/2.*eqvl
2542 ynsp1 = ynsp1/2.*eqvl
2543 ynsp2 = ynsp2/2.*eqvl
2545 end subroutine xtypm 2551 function gamci(phi, pcresi, gami, ist, qsc)
2552 implicit real *8(a-h, o-z)
2553 common /consta/vl, pi, xmat, rpel, qst
2554 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
2555 common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
2556 common /gaus17/h1(17), t1(17)
2561 tilta2 = phslip/(2.*eqvl)
2563 xcc = eqvl*(1.+h1(i))/2.
2564 phit0 = phi - phslip*(eqvl-xcc)/(2.*eqvl)
2566 if (phslip/=0.)
then 2567 git = cgi*sqcttf*cos(phit0-pcresi)/phslip
2568 gis = sin(xcc*tilta2)
2570 git = cgi*sqcttf*cos(phit0-pcrest)
2573 gamci = gami + git*gis
2581 subroutine intga(npt, ireca)
2582 implicit real *8(a-h, o-z)
2583 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
2584 common /consta/vl, pi, xmat, rpel, qst
2585 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
2586 common /hermt/afxt(22), afyt(22), afzt(22)
2587 common /hermd/afxm(20), afym(20), afzm(20)
2588 common /hermr/afxr(20), afyr(20), afzr(20)
2589 common /hermrr/afxrr(20), afyrr(20), afzrr(20)
2590 common /sizr/xrms3, yrms3, zrms3, zcgr3
2591 common /degherm/nmaz, nmazr, nmaxy
2592 common /sizt/xrms, yrms, zrms
2593 common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
2594 common /elcg/xcgd, ycgd, zcgd, xcgr, ycgr, zcgr
2595 common /faisc/f(10, iptsz), imax, ngood
2596 common /intgrt/ex, ey, ez
2597 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
2598 common /part/xc(iptsz), yc(iptsz), zc(iptsz)
2599 common /twcst/epsilon
2604 dimension ui(6), wi(6)
2605 data (ui(j), j=1, 6)/.033765, .169395, .380690, .619310, .830605, .966234/
2606 data (wi(j), j=1, 6)/.085662, .180381, .233957, .233957, .180381, .085662/
2610 freq = fh*0.5e-06/pi
2620 if (ireca==0 .or. ireca==4)
then 2646 qmpart = 1.0e-09*beamc/(float(imax)*freq)
2648 qmpart = qmpart*ratei
2649 const = qmpart/(2.*epsilon)
2650 dnorm = (xrmsc*yrmsc*zrmsc)**.333333333
2652 xsq = (xc(npt)-xgc)*(xc(npt)-xgc)
2653 ysq = (yc(npt)-ygc)*(yc(npt)-ygc)
2654 zsq = (zc(npt)-zgc)*(zc(npt)-zgc)
2655 if (ireca==0) zc1 = zc(npt) - zgc
2656 if (ireca==1) zc2 = zc(npt) - zgc
2658 if (ireca==2) zc2 = zc(npt) - zgc
2664 a1 = xrmsc*xrmsc - dsq + dsq/ui(j)
2665 a2 = yrmsc*yrmsc - dsq + dsq/ui(j)
2666 a3 = zrmsc*zrmsc - dsq + dsq/ui(j)
2670 txyz = sqrt(t1+t2+t3)
2671 ff1 =
drxyz(nmaxy, txyz, ireca)/(ui(j)*ui(j)*sqrt(a1*a2*a3))
2675 ex = ex + wi(j)*fxn*dsq
2676 ey = ey + wi(j)*fyn*dsq
2677 ez = ez + wi(j)*fzn*dsq
2680 ex = ex*const*xc(npt)
2681 ey = ey*const*yc(npt)
2682 ez = ez*const*(zc(npt)-zgc)
2684 end subroutine intga 2690 subroutine sizcor(ect, xrms, yrms, zrms, imaxd)
2691 implicit real *8(a-h, o-z)
2692 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
2693 common /part/xc(iptsz), yc(iptsz), zc(iptsz)
2694 common /cgrms/xsum, ysum, zsum
2695 common /faisc/f(10, iptsz), imax, ngood
2708 if (imaxd>0) imaxx = imaxd
2710 xcoup = abs(xc(i)/xrmsp)
2711 ycoup = abs(yc(i)/yrmsp)
2712 zcoup = abs(zc(i)/zrmsp)
2713 if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect)
then 2717 xsqsum = xsqsum + xc(i)*xc(i)
2718 ysqsum = ysqsum + yc(i)*yc(i)
2719 zsqsum = zsqsum + zc(i)*zc(i)
2726 xsqsum = xsqsum/imaxf
2727 ysqsum = ysqsum/imaxf
2728 zsqsum = zsqsum/imaxf
2729 xrms = sqrt(xsqsum-xsum*xsum)
2730 yrms = sqrt(ysqsum-ysum*ysum)
2731 zrms = sqrt(zsqsum-zsum*zsum)
2738 subroutine sizrms(imaxd, xrms, yrms, zrms, zmin)
2739 implicit real *8(a-h, o-z)
2740 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
2741 common /part/xc(iptsz), yc(iptsz), zc(iptsz)
2742 common /cgrms/xsum, ysum, zsum
2743 common /faisc/f(10, iptsz), imax, ngood
2751 zc(i) = zc(i) - zmin
2762 xsqsum = xsqsum + xc(i)*xc(i)
2763 ysqsum = ysqsum + yc(i)*yc(i)
2764 zsqsum = zsqsum + zc(i)*zc(i)
2769 xsqsum = xsqsum/float(imaxx)
2770 ysqsum = ysqsum/float(imaxx)
2771 zsqsum = zsqsum/float(imaxx)
2772 xrms = sqrt(xsqsum-xsum*xsum)
2773 yrms = sqrt(ysqsum-ysum*ysum)
2774 zrms = sqrt(zsqsum-zsum*zsum)
2781 function snzt(cc, dd)
2782 implicit real *8(a-h, o-z)
2783 common /degherm/nmaz, nmazr, nmaxy
2784 common /sizt/xrms, yrms, zrms
2785 common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
2786 common /gaus17/h1(17), t1(17)
2790 z = (cc+dd)/2. + (dd-cc)*h1(i)/2.
2791 denz =
densz(nmaz, z, 0)
2792 if (denz<0.) denz = 0.
2802 function snzd(cc, dd)
2803 implicit real *8(a-h, o-z)
2804 common /degherm/nmaz, nmazr, nmaxy
2805 common /sizt/xrms, yrms, zrms
2806 common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
2807 common /gaus17/h1(17), t1(17)
2811 z = (cc+dd)/2. + (dd-cc)*h1(i)/2.
2812 denz =
densz(nmaz, z, 0)
2813 if (denz<0.)
go to 13
2825 function vaprz(cc, dd)
2826 implicit real *8(a-h, o-z)
2827 common /degherm/nmaz, nmazr, nmaxy
2828 common /sizt/xrms, yrms, zrms
2829 common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
2830 common /gaus17/h1(17), t1(17)
2836 z = (cc+dd)/2. + (dd-cc)*h1(i)/2.
2837 denz =
densz(nmaz, z, 0)
2838 if (denz<0.)
go to 13
2840 var1 = var1 + t1(i)*zz*zz*denz
2841 var2 = var2 + t1(i)*denz
2851 function prinz(cc, dd, kap, zrmss1)
2852 implicit real *8(a-h, o-z)
2853 common /degherm/nmaz, nmazr, nmaxy
2854 common /sizt/xrms, yrms, zrms
2855 common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
2856 common /gaus17/h1(17), t1(17)
2862 z = (cc+dd)/2. + (dd-cc)*h1(i)/2.
2863 denz =
densz(nmaz, z, 0)
2864 if (denz<0.)
go to 13
2877 subroutine rchsom(zi, zf, nmaz)
2878 implicit real *8(a-h, o-z)
2880 xpz = abs((zf-zi))/400.
2883 if (ztest<=xpz)
return 2886 t1 =
densz(nmaz, z1, 0)
2887 t2 =
densz(nmaz, z2, 0)
2899 subroutine rchsor(aa, bb, cc, dd, zs)
2900 implicit real *8(a-h, o-z)
2904 xpz = abs((zf-zi))/400.
2907 if (ztest<=xpz)
then 2913 t1 =
dendif(z1, aa, bb, cc, dd)
2914 t2 =
dendif(z2, aa, bb, cc, dd)
2926 implicit real *8(a-h, o-z)
2941 he(k+2) = x*he(k+1) - float(k)*he(k)
2951 function densz(m, z, ireca)
2952 implicit real *8(a-h, o-z)
2953 common /hermt/afxt(22), afyt(22), afzt(22)
2954 common /hermd/afxm(20), afym(20), afzm(20)
2955 common /hermr/afxr(20), afyr(20), afzr(20)
2961 if (ireca==2)
densz =
densz + exp(-z*z/2.)*afzm(k)*
herm(2*kap, z)
2962 if (ireca==3)
densz =
densz + exp(-z*z/2.)*afzr(k)*
herm(2*kap, z)
2970 function codsy(bb, cc, dd, ee, kap)
2971 implicit real *8(a-h, o-z)
2972 common /degherm/nmaz, nmazr, nmaxy
2973 common /sizt/xrms, yrms, zrms
2974 common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
2975 common /gaus13/h(13), t(13)
2982 z = (cc+ff)/2. + (cc-ff)*t(i)/2.
2983 if (z>=ff .and. z<ee)
then 2986 if (zs<bb) dendifr =
densz(nmaz, zs, 0)
2987 if (zs>=bb) dendifr =
densz(nmaz, zs, 0) -
densz(nmaz, z1, 0)
2990 if (z<bb) dendifr =
densz(nmaz, z, 0)
2992 if (z>=bb) dendifr =
densz(nmaz, z, 0) -
densz(nmaz, z1, 0)
2994 if (dendifr<0.) dendifr = 0.
3007 function codif(bb, cc, dd, ee, ee1, kap)
3008 implicit real *8(a-h, o-z)
3009 common /degherm/nmaz, nmazr, nmaxy
3010 common /sizt/xrms, yrms, zrms
3011 common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
3012 common /sizr/xrms3, yrms3, zrms3, zcgr3
3013 common /gaus13/h(13), t(13)
3021 z = (ee+ff)/2. + (ee-ff)*t(i)/2.
3022 if (z<=ff1) dendifr =
densz(nmaz, z, 0)
3026 if (zs<bb) dendifr =
densz(nmaz, zs, 0)
3027 if (zs>=bb) dendifr =
densz(nmaz, zs, 0) -
densz(nmaz, z1, 0)
3028 dendifr =
densz(nmaz, z, 0) - dendifr
3030 if (z>0.) dendifr = 0.
3031 if (dendifr<0.) dendifr = 0.
3044 function varia(bb, cc, dd, ee)
3045 implicit real *8(a-h, o-z)
3046 common /degherm/nmaz, nmazr, nmaxy
3047 common /sizt/xrms, yrms, zrms
3048 common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
3049 common /gaus13/h(13), t(13)
3057 z = (cc+ff)/2. + (cc-ff)*t(i)/2.
3058 if (z>=ff .and. z<ee)
then 3061 if (zs<bb) dendifr =
densz(nmaz, zs, 0)
3062 if (zs>=bb) dendifr =
densz(nmaz, zs, 0) -
densz(nmaz, z1, 0)
3065 if (z<bb) dendifr =
densz(nmaz, z, 0)
3067 if (z>=bb) dendifr =
densz(nmaz, z, 0) -
densz(nmaz, z1, 0)
3070 if (dendifr<0.) dendifr = 0.
3071 codi1 = codi1 + h(i)*zz*zz*dendifr
3072 codi2 = codi2 + h(i)*dendifr
3081 function variz(bb, cc, dd, ee, ee1)
3082 implicit real *8(a-h, o-z)
3083 common /degherm/nmaz, nmazr, nmaxy
3084 common /sizt/xrms, yrms, zrms
3085 common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
3086 common /gaus13/h(13), t(13)
3095 z = (ee+ff)/2. + (ee-ff)*t(i)/2.
3096 if (z<=ff1) dendifr =
densz(nmaz, z, 0)
3100 if (zs<bb) dendifr =
densz(nmaz, zs, 0)
3101 if (zs>=bb) dendifr =
densz(nmaz, zs, 0) -
densz(nmaz, z1, 0)
3102 dendifr =
densz(nmaz, z, 0) - dendifr
3104 if (z>ee) dendifr = 0.
3105 if (dendifr<0.) dendifr = 0.
3107 codi1 = codi1 + h(i)*zz*zz*dendifr
3108 codi2 = codi2 + h(i)*dendifr
3117 function grz(aa, bb, cc, dd, ee)
3118 implicit real *8(a-h, o-z)
3119 common /degherm/nmaz, nmazr, nmaxy
3120 common /sizt/xrms, yrms, zrms
3121 common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
3122 common /gaus13/h(13), t(13)
3128 z = (ee+aa)/2. + (ee-aa)*t(i)/2.
3129 dif =
dendir(z, aa, bb, cc, dd, ee)
3130 if (dif<0.) dif = 0.
3131 gz = gz + h(i)*z*dif
3134 if (gs<=0.)
grz = 0.
3135 if (gs>0.)
grz = gz/gs
3143 function dendir(z, aa, bb, cc, dd, ee)
3144 implicit real *8(a-h, o-z)
3145 common /degherm/nmaz, nmazr, nmaxy
3151 if (z>=ff .and. z<ee)
then 3155 if (zs<bb) dendifr =
densz(nmaz, zs, 0)
3156 if (zs>=bb) dendifr =
densz(nmaz, zs, 0) -
densz(nmaz, z1, 0)
3167 function dendif(z, aa, bb, cc, dd)
3168 implicit real *8(a-h, o-z)
3169 common /degherm/nmaz, nmazr, nmaxy
3174 if (z>=bb .and. z<cc)
then 3186 function denpd(xyz, nmaxy, nmaz)
3187 implicit real *8(a-h, o-z)
3200 function drxyz(m, xyz, ireca)
3201 implicit real *8(a-h, o-z)
3202 common /hermt/afxt(22), afyt(22), afzt(22)
3203 common /hermd/afxm(20), afym(20), afzm(20)
3204 common /hermr/afxr(20), afyr(20), afzr(20)
3205 common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
3206 common /hermrr/afxrr(20), afyrr(20), afzrr(20)
3207 common /sizr/xrms3, yrms3, zrms3, zcgr3
3208 common /consta/vl, pi, xmat, rpel, qst
3212 if (abs(xyz)>13.) xyz = 13.
3213 fe = exp(-xyz*xyz/2.)
3220 dxxyz = fe*float(kap)*afxm(k)*
hers(kah, axyz)
3221 dyxyz = fe*float(kap)*afym(k)*
hers(kah, axyz)
3222 dzxyz = fe*float(kap)*afzm(k)*
hers(kah, axyz)
3223 deriv1 = deriv1 + (dxxyz+dyxyz+dzxyz)
3226 dxxyz = fe*float(kap)*afxr(k)*
hers(kah, axyz)
3227 dyxyz = fe*float(kap)*afyr(k)*
hers(kah, axyz)
3228 dzxyz = fe*float(kap)*afzr(k)*
hers(kah, axyz)
3229 deriv1 = deriv1 + (dxxyz+dyxyz+dzxyz)
3232 dxxyz = fe*float(kap)*afxrr(k)*
hers(kah, axyz)
3233 dyxyz = fe*float(kap)*afyrr(k)*
hers(kah, axyz)
3234 dzxyz = fe*float(kap)*afzrr(k)*
hers(kah, axyz)
3235 deriv1 = deriv1 + (dxxyz+dyxyz+dzxyz)
3241 dxxyz = -fe*afxm(k)*
herm(kap, xyz)
3242 dyxyz = -fe*afym(k)*
herm(kap, xyz)
3243 dzxyz = -fe*afzm(k)*
herm(kap, xyz)
3247 dxxyz = -fe*afxr(k)*
herm(kap, xyz)
3248 dyxyz = -fe*afyr(k)*
herm(kap, xyz)
3249 dzxyz = -fe*afzr(k)*
herm(kap, xyz)
3253 dxxyz = -fe*afxrr(k)*
herm(kap, xyz)
3254 dyxyz = -fe*afyrr(k)*
herm(kap, xyz)
3255 dzxyz = -fe*afzrr(k)*
herm(kap, xyz)
3268 implicit real *8(a-h, o-z)
3281 xm1 = float((m+1)/2) + .01
3284 he(k+2) =
herm(2*(k+2)-2, abs(x)) - float(2*(k+2)-2)*he(k+1)
3294 function copdr(xi, xf, kap)
3295 implicit real *8(a-h, o-z)
3296 common /degherm/nmaz, nmazr, nmaxy
3297 common /gaus13/h(13), t(13)
3302 z = (xi+xf)/2. + (xf-xi)*t(i)/2.
3314 function densx(m, x, ireca)
3315 implicit real *8(a-h, o-z)
3316 common /hermt/afxt(22), afyt(22), afzt(22)
3317 common /hermd/afxm(20), afym(20), afzm(20)
3318 common /hermr/afxr(20), afyr(20), afzr(20)
3323 if (ireca==0)
densx =
densx + exp(-x*x/2.)*afxt(k)*
herm(2*kap, abs(x))
3324 if (ireca==1)
densx =
densx + exp(-x*x/2.)*afxm(k)*
herm(2*kap, abs(x))
3333 function densy(m, y, ireca)
3334 implicit real *8(a-h, o-z)
3335 common /hermt/afxt(22), afyt(22), afzt(22)
3336 common /hermd/afxm(20), afym(20), afzm(20)
3337 common /hermr/afxr(20), afyr(20), afzr(20)
3342 if (ireca==0)
densy =
densy + exp(-y*y/2.)*afyt(k)*
herm(2*kap, abs(y))
3343 if (ireca==1)
densy =
densy + exp(-y*y/2.)*afym(k)*
herm(2*kap, abs(y))
3354 implicit real *8(a-h, o-z)
3355 common /degherm/nmaz, nmazr, nmaxy
3357 sp1 = (
densx(nmaxy,xyz,0)+
densy(nmaxy,xyz,0))/3.
3358 sp2 = (
densx(nmaxy,xyz,1)+
densy(nmaxy,xyz,1))/3.
3367 function scgx(xi, xf)
3368 implicit real *8(a-h, o-z)
3369 common /degherm/nmaz, nmazr, nmaxy
3370 common /gaus13/h(13), t(13)
3375 x = (xi+xf)/2. + (xf-xi)*t(i)/2.
3377 cgx = cgx + h(i)*dend
3378 cgxx = cgxx + h(i)*dend*x
3380 cgx = cgx*(xf-xi)/2.
3381 cgxx = cgxx*(xf-xi)/2.
3390 function scgy(xi, xf)
3391 implicit real *8(a-h, o-z)
3392 common /degherm/nmaz, nmazr, nmaxy
3393 common /gaus13/h(13), t(13)
3398 y = (xi+xf)/2. + (xf-xi)*t(i)/2.
3400 cgy = cgy + h(i)*dend
3401 cgyy = cgyy + h(i)*dend*y
3403 cgy = cgy*(xf-xi)/2.
3404 cgyy = cgyy*(xf-xi)/2.
3413 function corxy(xi, xf, kap, ik, xyrms)
3414 implicit real *8(a-h, o-z)
3415 common /degherm/nmaz, nmazr, nmaxy
3416 common /gaus13/h(13), t(13)
3421 z = (xi+xf)/2. + (xf-xi)*t(i)/2.
3422 if (ik==0) dend =
densx(nmaxy, z, 0) -
densx(nmaxy, z, 1)
3423 if (ik==1) dend =
densy(nmaxy, z, 0) -
densy(nmaxy, z, 1)
3424 if (dend<0.) dend = 0.
3437 function varxy(xi, xf, ik)
3438 implicit real *8(a-h, o-z)
3439 common /gaus13/h(13), t(13)
3440 common /degherm/nmaz, nmazr, nmaxy
3446 z = (xi+xf)/2. + (xf-xi)*t(i)/2.
3447 if (ik==0) dend =
densx(nmaxy, z, 0) -
densx(nmaxy, z, 1)
3448 if (ik==1) dend =
densy(nmaxy, z, 0) -
densy(nmaxy, z, 1)
3449 corxy1 = corxy1 + h(i)*z*z*dend
3450 corxy2 = corxy2 + h(i)*dend
3452 varxy = corxy1/corxy2
3460 function varzr(ee, cc, nmazr)
3461 implicit real *8(a-h, o-z)
3464 smt =
densz(nmazr, 0.0d0, 3)/2.
3470 spl =
densz(nmazr, z1, 3)
3471 if (abs(spl-smt)<=smte)
go to 10
3499 subroutine cdg(idch)
3500 implicit real *8(a-h, o-z)
3501 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
3502 common /faisc/f(10, iptsz), imax, ngood
3503 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
3504 common /etcom/cog(8), exten(17), fd(iptsz)
3505 common /dyn/tref, vref
3517 if (ichas(i)==1)
then 3518 cog(1) = cog(1) + f(7, i)
3519 cog(3) = cog(3) + f(6, i)
3520 cog(4) = cog(4) + f(2, i)
3521 cog(5) = cog(5) + f(3, i)
3522 cog(6) = cog(6) + f(4, i)
3523 cog(7) = cog(7) + f(5, i)
3529 cog(1) = cog(1) + f(7, i)
3530 cog(3) = cog(3) + f(6, i)
3531 cog(4) = cog(4) + f(2, i)
3532 cog(5) = cog(5) + f(3, i)
3533 cog(6) = cog(6) + f(4, i)
3534 cog(7) = cog(7) + f(5, i)
3538 cog(1) = cog(1)/imaxf
3539 cog(3) = cog(3)/imaxf
3540 cog(4) = cog(4)/imaxf
3541 cog(5) = cog(5)/imaxf
3542 cog(6) = cog(6)/imaxf
3543 cog(7) = cog(7)/imaxf
3577 subroutine ext2d(idch)
3578 implicit real *8(a-h, o-z)
3579 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
3580 common /consta/vl, pi, xmat, rpel, qst
3581 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
3582 common /faisc/f(10, iptsz), imax, ngood
3584 common /dyn/tref, vref
3585 common /dyni/vrefi, trefi, fhinit, acpt
3586 common /etcom/cog(8), exten(17), fd(iptsz)
3587 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
3588 dimension ffd(iptsz)
3589 logical chasit, acpt
3610 bcog = sqrt(1.-1./(gcog*gcog))
3616 gref = 1./sqrt(1.-bref*bref)
3620 bpai = sqrt(1.-1./(gpai*gpai))
3625 fd(i) = (gpai*bpai)/(gref*bref)
3626 ffd(i) = (gpai*bpai)/(gcog*bcog)
3631 fdp = f(7, i) - cog(1)
3632 trph1 = fh*(f(6,i)-cog(3))
3633 trxf = f(2, i) - cog(4)
3634 trtf = f(3, i) - cog(5)
3635 tryf = f(4, i) - cog(6)
3636 trpf = f(5, i) - cog(7)
3638 if (idch==1 .and. ichas(i)==1)
then 3639 exten(1) = exten(1) + fdp**2
3640 exten(2) = exten(2) + trph1*fdp
3641 exten(3) = exten(3) + trph1**2
3642 exten(4) = exten(4) + trxf**2
3643 exten(5) = exten(5) + trtf**2
3644 exten(6) = exten(6) + tryf**2
3645 exten(7) = exten(7) + trpf**2
3646 exten(8) = exten(8) + trxf*trtf
3647 exten(9) = exten(9) + tryf*trpf
3648 exten(12) = exten(12) + fdpp*trxf
3649 exten(13) = exten(13) + fdpp*tryf
3650 exten(14) = exten(14) + fdpp**2
3651 exten(15) = exten(15) + ffdpp*trxf
3652 exten(16) = exten(16) + ffdpp*tryf
3653 exten(17) = exten(17) + ffdpp**2
3654 qmoy = qmoy + f(9, i)
3659 exten(1) = exten(1) + fdp**2
3660 exten(2) = exten(2) + trph1*fdp
3661 exten(3) = exten(3) + trph1**2
3662 exten(4) = exten(4) + trxf**2
3663 exten(5) = exten(5) + trtf**2
3664 exten(6) = exten(6) + tryf**2
3665 exten(7) = exten(7) + trpf**2
3666 exten(8) = exten(8) + trxf*trtf
3667 exten(9) = exten(9) + tryf*trpf
3668 exten(12) = exten(12) + fdpp*trxf
3669 exten(13) = exten(13) + fdpp*tryf
3670 exten(14) = exten(14) + fdpp**2
3671 exten(15) = exten(15) + ffdpp*trxf
3672 exten(16) = exten(16) + ffdpp*tryf
3673 exten(17) = exten(17) + ffdpp**2
3674 qmoy = qmoy + f(9, i)
3679 exten(i) = exten(i)/float(imaxf)
3682 exten(i) = exten(i)/float(imaxf)
3684 qmoy = qmoy/float(imaxf)
3686 end subroutine ext2d 3720 subroutine ext2(idch)
3721 implicit real *8(a-h, o-z)
3722 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
3723 common /consta/vl, pi, xmat, rpel, qst
3724 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
3725 common /faisc/f(10, iptsz), imax, ngood
3727 common /dyn/tref, vref
3728 common /dyni/vrefi, trefi, fhinit, acpt
3729 common /etcom/cog(8), exten(17), fd(iptsz)
3730 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
3731 dimension fdd(iptsz)
3732 logical chasit, acpt
3754 bcog = sqrt(1.-1./(gcog*gcog))
3760 gref = 1./sqrt(1.-bref*bref)
3764 bpai = sqrt(1.-1./(gpai*gpai))
3769 fd(i) = (gpai*bpai)/(gcog*bcog)
3770 fdd(i) = (gpai*bpai)/(gref*bref)
3775 dener = f(7, i) - cog(1)
3776 trph1 = fh*(f(6,i)-cog(3))
3777 trxf = f(2, i) - cog(4)
3778 trtf = f(3, i) - cog(5)
3779 tryf = f(4, i) - cog(6)
3780 trpf = f(5, i) - cog(7)
3781 if (idch==1 .and. ichas(i)==1)
then 3782 exten(1) = exten(1) + fdp**2
3783 exten(2) = exten(2) + trph1*fdp
3784 exten(3) = exten(3) + trph1**2
3785 exten(4) = exten(4) + trxf**2
3786 exten(5) = exten(5) + trtf**2
3787 exten(6) = exten(6) + tryf**2
3788 exten(7) = exten(7) + trpf**2
3789 exten(8) = exten(8) + trxf*trtf
3790 exten(9) = exten(9) + tryf*trpf
3791 exten(10) = exten(10) + dener*dener
3792 exten(11) = exten(11) + dener*trph1
3793 exten(12) = exten(12) + fddp*trxf
3794 exten(13) = exten(13) + fddp*tryf
3795 exten(14) = exten(14) + fddp**2
3796 exten(15) = exten(15) + fdp*trxf
3797 exten(16) = exten(16) + fdp*tryf
3798 exten(17) = exten(17) + fdp**2
3799 qmoy = qmoy + f(9, i)
3803 exten(1) = exten(1) + fdp**2
3804 exten(2) = exten(2) + trph1*fdp
3805 exten(3) = exten(3) + trph1**2
3806 exten(4) = exten(4) + trxf**2
3807 exten(5) = exten(5) + trtf**2
3808 exten(6) = exten(6) + tryf**2
3809 exten(7) = exten(7) + trpf**2
3810 exten(8) = exten(8) + trxf*trtf
3811 exten(9) = exten(9) + tryf*trpf
3812 exten(10) = exten(10) + dener*dener
3813 exten(11) = exten(11) + dener*trph1
3814 exten(12) = exten(12) + fddp*trxf
3815 exten(13) = exten(13) + fddp*tryf
3816 exten(14) = exten(14) + fddp**2
3817 exten(15) = exten(15) + fdp*trxf
3818 exten(16) = exten(16) + fdp*tryf
3819 exten(17) = exten(17) + fdp**2
3820 qmoy = qmoy + f(9, i)
3825 exten(i) = exten(i)/float(imaxf)
3827 qmoy = qmoy/float(imaxf)
3839 implicit real *8(a-h, o-z)
3840 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
3841 common /consta/vl, pi, xmat, rpel, qst
3842 common /faisc/f(10, iptsz), imax, ngood
3844 common /tapes/in, ifile, meta
3846 read (in, *) xc, yc, a
3848 write (16, 100) xc, yc, a
3855 x = ((x-yc)*cos(xp)+xc*sin(xp))/cos(xp-a)
3858 yl = yc - x0 + x*cos(a)
3859 dl = sqrt(xl*xl+yl*yl)
3867 100
format (
' New reference frame XC =', f6.2,
' CM , YC =', f6.2,
' CM , A =', f6.4,
' RADIAN', ///)
3882 implicit real *8(a-h, o-z)
3883 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
3884 common /consta/vl, pi, xmat, rpel, qst
3885 common /faisc/f(10, iptsz), imax, ngood
3887 common /tapes/in, ifile, meta
3888 common /mcs/imcs, ncstat, cstat(20)
3889 dimension charge(20), pcent(20), charm(20), pc(20), eoff(20), vecx(1)
3890 dimension foo(20, 9), ndp(20)
3891 character *80 myfile
3902 read (in, 3333) myfile(1:80)
3904 write (16, *)
'Charge state distribution file: ', myfile(1:80)
3905 open (56, file=myfile, status=
'unknown')
3907 write (16, *)
'Maximum number of particles:', imax
3908 write (16, *)
'Number of good particles:', ngood
3909 write (16, *)
'Number of particles in charge state file:', ntot
3910 if (ntot<ngood)
then 3911 write (16, *)
'Not enough particles in charge state file' 3915 read (56, *) chstate
3924 read (in, *) charm(i), pc(i), eoff(i)
3926 pourc = pourc + pc(i)
3927 if (pourc>100.)
then 3928 write (16, 100) i, pourc
3935 pourc = pourc + pc(i)
3937 if (pourc/=100.)
then 3938 write (16, 120) pourc
3946 if (ts>=charm(i))
then 3956 write (16, *)
'**********************' 3960 write (16, 110) charge(i), pcent(i), eoff(i)
3961 if (charge(i)==qst) jjj = 1
3965 pcent(1) = pcent(1)/100.
3967 pcent(i) = pcent(i-1) + pcent(i)/100.
3970 call rlux(vecx, len)
3972 if (xarpha<=pcent(1))
then 3974 f(7, i) = f(7, i) + eoff(1)
3977 if (xarpha>pcent(j) .and. xarpha<=pcent(j+1))
then 3978 f(7, i) = f(7, i) + eoff(j+1)
3979 f(9, i) = charge(j+1)
3994 if (f(9,i)==cstat(k))
then 3997 foo(k, j) = foo(k, j) + f(j, i)
4004 foo(k, j) = foo(k, j)/float(ndp(k))
4008 gref = foo(k, 7)/xmat
4009 bref = sqrt(1.-1./(gref*gref))
4012 bor = 3.3356*xmat*bref*gref/cstat(k)
4013 write (16, *)
' Q: ', cstat(k),
' COG : energy ', xe,
' MeV momentum ', bor,
' kG.cm' 4015 100
format (3x,
' WRONG PERCENTAGE IN CHARGE STATE DISTRIBUTION', /, 4x,
' CHARGE STATE ', i3,
' PERCENTAGE ', e12.5)
4016 110
format (3x,
' CHARGE STATE ', f6.1,
' PERCENTAGE ', e12.5,
' %', 4x,
' ENERGY OFFSET ', e12.5,
' MeV')
4017 120
format (3x,
' TOTAL PERCENTAGE OF ALL CHARGE STATES < 100 %', /, 4x,
' PERCENTAGE ', e12.5)
4018 140
format (3x,
' NUMBER OF CHARGE STATES : ', i3,
' GREATER THAN 20')
4027 subroutine crest(betr, eqvl, xpos, bkcr, ffield)
4028 implicit real *8(a-h, o-z)
4029 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
4030 common /func/a(200), ylg, atte, ncel, nharm
4031 common /consta/vl, pi, xmat, rpel, qst
4036 be2 = betr - 8.333e-03*betr
4042 t1 =
tta0(be1)*ffield
4043 s1 =
tsb0(be1)*ffield
4044 tp1 =
tta1(be1)*ffield
4045 sp1 =
tsb1(be1)*ffield
4046 t2 =
tta0(be2)*ffield
4047 s2 =
tsb0(be2)*ffield
4048 tp2 =
tta1(be2)*ffield
4049 sp2 =
tsb1(be2)*ffield
4050 dts = (t1*tp1+s1*sp1)/(t1*t1+s1*s1)
4051 a1k12 = (t1*tp1+s1*sp1)/(t2*tp2+s2*sp2)
4052 a2k12 = (t2*t2+s2*s2)/(t1*t1+s1*s1)
4055 bk12 = (xk2-xk1)/(ak12-1.)
4057 desy = -4.*atan(dts*3.2/xleq)
4060 if (abs(desy)>=epsrd)
then 4063 ftil = til2/tan(til2) - 1. - bk12
4064 dftil = -til2/(sin(til2)*sin(til2)) + 1./tan(til2)
4065 til2 = til2 - ftil/dftil
4069 if (abs(desy)<epsrd)
then 4070 xpos = (t1*sp1-s1*tp1)/(t1*t1+s1*s1)
4071 bkcr = sqrt(t1*t1+s1*s1)
4076 xleq = desy*(ak12-1.)/(xk2-xk1)
4079 becrt = fh/(vl*xkcrt)
4081 be2 = becrt - becrt/120.
4083 end subroutine crest 4097 subroutine gaus(r1, r2, z1, z2, opt, er, ez)
4098 implicit real *8(a-h, o-z)
4099 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
4100 dimension r(6), z(6), wr(6), wz(6), xx(3, 3), wx(3, 3)
4101 data ((xx(i,j),i=1,3), j=1, 3)/.2113248654, 0.0, 0.0, .06943184420, .33000947820, 0.0, .03376524290, .16939530680, &
4103 data ((wx(i,j),i=1,3), j=1, 3)/.50, 0.0, 0.0, .17392742260, .32607257740, 0.0, .085662246190, .1803807865000, &
4111 if (opt<0.)
go to 20
4115 if (rat>=1.)
go to 10
4118 10
if (rat>2.) m = 2
4124 r(k) = r1 + cr*xx(i, ir)
4125 r(k+1) = r2 - cr*xx(i, ir)
4131 z(k) = z1 + cz*xx(j, jz)
4132 z(k+1) = z2 - cz*xx(j, jz)
4142 call flds(r(i), z(j), er1, ez1)
4143 ser = ser + wr(i)*wz(j)*er1*r(i)
4144 sez = sez + wr(i)*wz(j)*ez1*r(i)
4157 subroutine flds(r, z, er, ez)
4158 implicit real *8(a-h, o-z)
4159 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
4160 common /fldcom/rp, zp, pl, opt, nip
4168 a = 4.0*r*r1/(b+d**2)
4169 call eint(a, ee, ek)
4172 if (r1==0.)
go to 10
4173 er1 = (ek-(r**2-r1**2+d**2)*ee/(c+d**2))/(2.0*r1*a)
4174 10 ez1 = d*ee/(a*(c+d**2))
4175 if (nip==0)
go to 50
4180 a = 4.0*r*r1/(b+d**2)
4181 call eint(a, ee, ek)
4183 if (r1==0.)
go to 20
4184 er1 = er1 + (ek-(r**2-r1**2+d**2)*ee/(c+d**2))/(2.0*r1*a)
4185 20 ez1 = ez1 + d*ee/(a*(c+d**2))
4197 subroutine eint(a, ee, ek)
4198 implicit real *8(a-h, o-z)
4199 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
4203 ee = 1.0 + b*(.4630106-0.2452740*c+b*(0.1077857-0.04125321*c))
4204 ek = 1.38629436 - .5*c + b*(0.1119697-0.1213486*c+b*(.07253230-.028874721*c))
4211 subroutine tiltz(tilta)
4212 implicit real *8(a-h, o-z)
4213 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
4214 common /consta/vl, pi, xmat, rpel, qst
4215 common /faisc/f(10, iptsz), imax, ngood
4218 common /dyn/tref, vref
4219 common /tapes/in, ifile, meta
4220 common /etcom/cog(8), exten(17), fd(iptsz)
4223 1
format (
' tilt in the plane (x,z) around the c.o.g',
' ANGLE :', e12.5,
' DEG', /)
4224 tilta = tilta*pi/180.
4229 vref = vref + vl*sqrt(1.-1./(gpai*gpai))
4230 tref = tref + f(6, i)
4232 vref = vref/float(imax)
4233 tref = tref/float(imax)
4238 vpai = sqrt(1.-1./(gpai*gpai))*vl
4239 trot = (f(6,i)-tref)*cos(tilta) - sin(tilta)*f(2, i)/vpai
4240 xrot = (f(6,i)-tref)*sin(tilta)*vpai + cos(tilta)*f(2, i)
4243 tref1 = tref1 + f(6, i)
4244 vref1 = vref1 + vpai
4246 tref = tref1/float(imax)
4247 vref = vref1/float(imax)
4249 end subroutine tiltz 4266 implicit real *8(a-h, o-z)
4267 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
4269 common /consta/vl, pi, xmat, rpel, qst
4270 common /dyn/tref, vref
4271 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
4272 common /faisc/f(10, iptsz), imax, ngood
4273 common /tapes/in, ifile, meta
4274 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
4275 common /etcom/cog(8), exten(17), fd(iptsz)
4276 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
4277 common /fene/wdisp, wphas, wx, wy, rlim, ifw
4279 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
4280 common /compt/nrres, nrtre, nrbunc, nrdbun
4281 common /shif/dtiph, shift
4282 common /femt/iemgrw, iemqesg
4284 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
4287 common /azlist/icont, iprin
4288 common /trfq/icour, ncell
4289 logical iesp, ichaes, shift, iemgrw, iflag
4290 common /itvole/itvol, imamin
4291 common /tofev/ttvols
4292 logical itvol, imamin
4306 if (iprf==1)
call stapl(davtot*10.)
4311 write (16, *)
'*** cell :', ncell + 1,
' length (cm): ', cl*100.
4312 write (16, *)
'*** V/r0**2 (kV/mm**2): ', vorsq/1000.
4313 write (16, *)
'*** AV (kV): ', av*1000.
4314 if (type==0.)
write (16, *)
'*** no acceleration, standard cell ' 4315 if (type==1.)
write (16, *)
'*** acceleration, standard cell ' 4316 if (type==2.)
write (16, *)
'*** no acceleration, fringing field region ' 4317 if (type==3.)
write (16, *)
'*** acceleration, fringing field region ' 4318 wavel = 2.*pi*vlm/fh
4331 tcog = tcog + f(6, i)
4332 ecog = ecog + f(7, i)
4335 tcog = tcog/float(ngood)
4336 ecog = ecog/float(ngood)
4339 bcog = sqrt(1.-1./(gcog*gcog))
4343 if (.not. shift)
then 4344 write (16, *)
'*** ref. part. and cog coincide in ncell = 0' 4353 write (16, *)
'*** ref. part. and cog separated in ncell = 0' 4355 gref = 1./sqrt(1.-bref*bref)
4362 ns = int(36.*cl/(bref*wavel))
4365 178
format (/,
' Dynamics at input', /, 5x,
' BETA GAMMA ENERGY(MeV) ',
' TOF(deg) TOF(sec)')
4366 write (16, 1788) bcog, gcog, wcog, tcog*fh*180./pi, tcog
4367 1788
format (
' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
4368 write (16, 165) bref, gref, wref, tref*fh*180./pi, tref
4369 165
format (
' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
4373 dav1(idav, 1) = cl*1000.
4374 dav1(idav, 2) = vorsq/1000.
4375 dav1(idav, 3) = av*1000
4376 davtot = davtot + cl*100.
4377 dav1(idav, 4) = davtot*10.
4378 dav1(idav, 5) =
type 4380 phini = -tref*fh + p(4)*radian
4382 write (16, 3945) ph0, p(4)
4383 3945
format (
'phase offset at input : ', e12.5,
' deg phase shift: ', e12.5,
' deg')
4389 tref = tref + hl/(bref*vlm)
4390 if (itvol) ttvols = tref
4391 phref = tref*fh + phini
4396 c3kz = cos(3.*cay*z)
4397 skz = .75*(skz+sin(3.*cay*z))
4400 if (type/=0. .and. type/=2.)
then 4402 dwref = .5*qst*cay*av*skz*sp*xl
4403 wrefm = wref + 0.5*
dwref 4404 grefm = wrefm/er + 1.
4405 brefm = sqrt(1.-1./(grefm*grefm))
4408 bref = sqrt(1.-1./(gref*gref))
4415 xi = f(2, ip)*1.e-02
4416 xpi = f(3, ip)*1.e-03
4417 yi = f(4, ip)*1.e-02
4418 ypi = f(5, ip)*1.e-03
4421 bi = sqrt(1.-1./(gi*gi))
4423 tim = f(6, ip) + hl/(bi*vlm)
4424 phi = phini + fh*tim
4437 rm = sqrt(xm*xm+ym*ym)
4445 write (16, 5556) ip, rm, rlimm
4446 5556
format (
' particle lost: ', i5,
' radius (m): ', e12.5,
' barrier (m):', e12.5)
4452 if (abs(xm)>1.e-10) theta = atan(ym/xm)
4453 if (abs(xm)<=1.e-10)
then 4454 if (abs(ym)>1.e-10)
then 4455 if (xm>=0. .and. ym>0.) theta = pi/2
4456 if (xm>=0. .and. ym<0.) theta = -pi/2
4457 if (xm<0. .and. ym<0.) theta = pi/2
4458 if (xm<0. .and. ym>0.) theta = -pi/2
4460 if (abs(ym)<=1.e-10) theta = 0.
4465 bi0 = 1. + zrm*zrm/4. + zrm**4/64. + zrm**6/2304.
4466 bi1 = zrm/2. + zrm**3/16.
4468 erf = vorsq*cos(2.*theta)*2.*rm + cay*(av*bi1)*ckz
4470 etf = vorsq*sin(theta)*2.*rm
4472 ex = erf*cos(theta) - etf*sin(theta)
4473 ey = erf*sin(theta) + etf*cos(theta)
4475 if (type/=0. .and. type/=2.)
then 4479 ez = 0.5*(av*bi0)*skz*cay
4483 dw = .5*qq*cay*avb*skz*sp*xl
4487 bgav = sqrt(ga*(2.+ga))
4494 bg = sqrt(ga*(2.+ga))
4495 beta = sqrt(1.-1/(gam*gam))
4497 if (type<2.) dez = qq*ez*sp
4498 if (type>2.) dez = .5*qq*cay*avb*skz*sp
4499 delt = .5*(dez/er)*xl*xl/(bav**3*gav**3*vlm)
4505 cc = qq*xl*sp/(bgfac*er)
4509 if (xm<0.) signx = -1.
4510 if (ym<0.) signy = -1.
4513 if (xm<0.) signx = -1.
4514 if (ym>0.) signy = -1.
4522 xpm = xpi*amort + rr1
4523 ypm = ypi*amort + rr2
4533 rf2 = .25*qq*cay*cay*avb/er
4534 c1 = rf1*sp*xl/bgfac
4535 c2 = rf2*ckz*sp*xl/bgfac
4536 c1 = c1*.75*(ckz+c3kz/3.)
4537 c2 = c2*.75*(ckz+3.*c3kz)
4540 xpm = xpi*amort + rr1*xm
4541 ypm = ypi*amort + rr2*ym
4548 f(3, ip) = xpm*1000.
4549 f(5, ip) = ypm*1000.
4551 f(6, ip) = f(6, ip) + hl/(bi*vlm) + hl/(beta*vlm) + delt
4576 tref = tref + hl/(bref*vlm) + dref
4577 if (itvol) ttvols = tref
4585 dtvl = (f(6,i)-tref)*fh
4586 if (dtvl>pi) f(6, i) = f(6, i) - 2.*pi/fh
4587 if (dtvl<-pi) f(6, i) = f(6, i) + 2.*pi/fh
4593 tcog = tcog + f(6, i)
4594 ecog = ecog + f(7, i)
4596 tcog = tcog/float(ngood)
4597 ecog = ecog/float(ngood)
4599 bcog = sqrt(1.-1./(gcog*gcog))
4605 if (ifw==0) dispr = gcog*gcog*wdisp/(gcog*(gcog+1.))
4606 if (ifw==1) dispr = gcog*gcog*wdisp/(gcog*(gcog+1.)*wcog)
4609 dese = abs(fd(i)-1.)
4610 if (dese>dispr)
then 4613 write (16, *)
' particle lost: ', i,
' dp/p: ', dese,
' in window :', dispr
4623 tcog = tcog + f(6, i)
4624 ecog = ecog + f(7, i)
4626 tcog = tcog/float(ngood)
4627 ecog = ecog/float(ngood)
4629 bcog = sqrt(1.-1./(gcog*gcog))
4633 179
format (/,
' Dynamics at the output', /, 5x,
' BETA GAMMA ENERGY(MeV) ', &
4634 ' TOF(deg) TOF(sec)')
4635 write (16, 1788) bcog, gcog, wcog, tcog*fh*180./pi, tcog
4636 write (16, 165) bref, gref, wref, tref*fh*180./pi, tref
4637 write (16, *)
' time of flight: ', ttvols*fh*180./pi,
' deg' 4643 tofprt = fh*tcog*180./pi
4644 n2kp = int(tofprt/360.)
4645 tofprt = tofprt - float(n2kp)*360.
4646 if (tofprt>180.) tofprt = tofprt - 360.
4652 trnsms = 100.*float(ngood)/float(imax)
4653 if (ncell==1)
write (50, *)
'# rfq_o3.dmp' 4654 write (50, 7023) ncell, trnsms, p(4), tofprt, bcog, wccog, bets, wref, 0.25*dav1(idav, 16), 0.25*dav1(idav, 21), &
4656 7023
format (1x, i4, 1x, f6.2, 2(1x,f8.3), 2(1x,f7.5,1x,f11.4), 3(1x,f11.4))
4660 xmor = xmat*bref*gref
4661 boro = 33.356*xmor*1.e-01/qst
4662 dav1(idav, 6) = (gref-1.)*er - wrefi
4663 dav1(idav, 36) = ngood
4665 call stapl(davtot*10.)
4677 subroutine tdens(m, ireca, iacc)
4678 implicit real *8(a-h, o-z)
4679 common /hermt/afxt(22), afyt(22), afzt(22)
4680 common /hermd/afxm(20), afym(20), afzm(20)
4681 common /hermr/afxr(20), afyr(20), afzr(20)
4682 common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
4683 common /consta/vl, pi, xmat, rpel, qst
4688 fc =
drxyz(m, t, ireca)
4692 fu =
drxyz(m, t, ireca)
4700 if (abs(fc/f1)>1.2) iacc = 1
4702 end subroutine tdens 4722 implicit real *8(a-h, o-z)
4723 common /tapes/in, ifile, meta
4724 common /rcshef/sce(20)
4738 read (in, *) sce(2), sce(3), sce(4), sce(5), sce(6), sce(7), sce(9)
4751 subroutine intg3(npt)
4752 implicit real *8(a-h, o-z)
4753 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
4754 common /consta/vl, pi, xmat, rpel, qst
4755 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
4756 common /hermt/afxt(22), afyt(22), afzt(22)
4757 common /hermd/afxm(20), afym(20), afzm(20)
4758 common /hermr/afxr(20), afyr(20), afzr(20)
4759 common /hermrr/afxrr(20), afyrr(20), afzrr(20)
4760 common /sizr/xrms3, yrms3, zrms3, zcgr3
4761 common /degherm/nmaz, nmazr, nmaxy
4762 common /sizt/xrms, yrms, zrms
4763 common /sizzt/xrmsz, yrmsz, zrmsz
4764 common /elcg/xcgd, ycgd, zcgd, xcgr, ycgr, zcgr
4765 common /intgrt/ex, ey, ez
4766 common /faisc/f(10, iptsz), imax, ngood
4767 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
4769 common /part/xc(iptsz), yc(iptsz), zc(iptsz)
4770 common /twcst/epsilon
4772 common /cgrms/xsum, ysum, zsum
4774 dimension ui(6), wi(6)
4775 data (ui(j), j=1, 6)/.033765, .169395, .380690, .619310, .830605, .966234/
4776 data (wi(j), j=1, 6)/.085662, .180381, .233957, .233957, .180381, .085662/
4780 freq = fh*0.5e-06/pi
4787 qmpart = 1.0e-09*beamc/(float(ngood)*freq)
4789 const = qmpart/(2.*epsilon)
4790 dnorm = (xrmsc*yrmsc*zrmsc)**.333333333
4792 xsq = (xc(npt)-xgc)*(xc(npt)-xgc)
4793 ysq = (yc(npt)-ygc)*(yc(npt)-ygc)
4794 zsq = (zc(npt)-zgc)*(zc(npt)-zgc)
4801 a1 = xrmsc*xrmsc - dsq + dsq/ui(j)
4802 a2 = yrmsc*yrmsc - dsq + dsq/ui(j)
4803 a3 = zrmsc*zrmsc - dsq + dsq/ui(j)
4807 txyz = sqrt(t1+t2+t3)
4808 if (abs(txyz)>13.) txyz = 13.
4809 ff1 = exp(-txyz*txyz/2.)*afzt(1)
4811 fxn = ff1/(ui(j)*ui(j)*sqrt(a1)*a1*sqrt(a2)*sqrt(a3))
4812 fyn = ff1/(ui(j)*ui(j)*sqrt(a1)*a2*sqrt(a2)*sqrt(a3))
4813 fzn = ff1/(ui(j)*ui(j)*sqrt(a1)*a3*sqrt(a2)*sqrt(a3))
4814 ex = ex + wi(j)*fxn*dsq
4815 ey = ey + wi(j)*fyn*dsq
4816 ez = ez + wi(j)*fzn*dsq
4819 ex = ex*const*(xc(npt)-xgc)
4820 ey = ey*const*(yc(npt)-ygc)
4821 ez = ez*const*(zc(npt)-zgc)
4823 end subroutine intg3 4829 implicit real *8(a-h, o-z)
4830 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
4831 common /consta/vl, pi, xmat, rpel, qst
4832 common /faisc/f(10, iptsz), imax, ngood
4835 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
4850 tcog = tcog + f(6, i)
4852 tcog = tcog/float(ngood)
4853 write (16, 58) tcog*fh*180./pi
4854 58
format (
' cog phase before shifting particles: ', e13.7,
' deg')
4856 drad = (f(6,i)-tcog)*fh
4858 f(6, i) = (f(6,i)-2.*pi/fh)
4861 f(6, i) = (f(6,i)+2.*pi/fh)
4867 tcog = tcog + f(6, i)
4869 tcog = tcog/float(ngood)
4870 write (16, 59) tcog*fh*180./pi
4871 59
format (
' cog phase after shifting particles : ', e13.7,
' deg')
4878 subroutine prbeam(iflg, wfile)
4879 implicit real *8(a-h, o-z)
4880 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
4881 common /consta/vl, pi, xmat, rpel, qst
4882 common /faisc/f(10, iptsz), imax, ngood
4883 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
4884 common /sc3/beamc, scdist, sce10, cplm, ectt, apl, ichaes, iscsp
4885 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
4886 common /dyn/tref, vref
4887 common /mcs/imcs, ncstat, cstat(20)
4888 common /tapes/in, ifile, meta
4889 common /etcha3/ichxyz(iptsz)
4891 common /etcom/cog(8), exten(17), fd(iptsz)
4904 ecog = ecog + f(7, i)
4905 tcog = tcog + f(6, i)
4907 xpav = xpav + f(3, i)
4909 ypav = ypav + f(5, i)
4911 ecog = ecog/float(ngood)
4912 tcog = tcog/float(ngood)
4913 xav = xav/float(ngood)
4914 xpav = xpav/float(ngood)
4915 yav = yav/float(ngood)
4916 ypav = ypav/float(ngood)
4919 gamref = 1./sqrt(1.-(beref*beref))
4921 open (58, file=wfile, status=
'unknown')
4923 write (58, *) ngood, beamc, fh/(2000000.*pi)
4925 write (60, *) ngood, beamc, fh/(2000000.*pi)
4926 write (61, *) ngood, beamc, fh/(2000000.*pi)
4929 write (58, *) ngood, beamc, fh/(2000000.*pi), enref - xmat
4931 write (60, *) ngood, beamc, fh/(2000000.*pi), enref - xmat
4932 write (61, *) ngood, beamc, fh/(2000000.*pi), enref - xmat
4942 eprt = f(7, i) - enref
4943 tprt = fh*(f(6,i)-tref)
4951 eprt = f(7, i) - xmat
4952 tprt = fh*(f(6,i)-tcog)
4961 tprt = fh*(f(6,i)-tcog)
4962 eprt = f(7, i) - ecog
4968 if (iflg==0 .or. iflg==100)
write (58, 100) f2, f3/1000., f4, f5/1000., tprt, eprt
4969 if (iflg==1 .or. iflg==101)
write (58, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(1, i)
4970 if (iflg==2 .or. iflg==102)
write (58, 102) f2, f3/1000., f4, f5/1000., tprt, eprt, f(9, i)
4971 if (iflg==3 .or. iflg==103)
write (58, 103) f2, f3/1000., f4, f5/1000., tprt, eprt, f(9, i), f(1, i)
4972 if (iflg==10 .or. iflg==110)
write (58, 100) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt
4973 if (iflg==11 .or. iflg==111)
write (58, 101) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(1, i)
4974 if (iflg==12 .or. iflg==112)
write (58, 102) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(9, i)
4975 if (iflg==13 .or. iflg==113)
write (58, 103) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(9, i), f(1, i)
4978 if (ichxyz(i)==0)
then 4979 if (iflg==0 .or. iflg==100)
write (60, 100) f2, f3/1000., f4, f5/1000., tprt, eprt
4980 if (iflg==10 .or. iflg==110)
write (60, 100) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt
4981 if (iflg==1 .or. iflg==101)
write (60, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(1, i)
4982 if (iflg==11 .or. iflg==111)
write (60, 102) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(1, i)
4983 if (iflg==2 .or. iflg==102)
write (60, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(9, i)
4984 if (iflg==12 .or. iflg==112)
write (60, 102) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(9, i)
4987 if (ichxyz(i)==1)
then 4988 if (iflg==0 .or. iflg==100)
write (61, 100) f2, f3/1000., f4, f5/1000., tprt, eprt
4989 if (iflg==10 .or. iflg==110)
write (61, 100) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt
4990 if (iflg==1 .or. iflg==101)
write (61, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(1, i)
4991 if (iflg==11 .or. iflg==111)
write (61, 102) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(1, i)
4992 if (iflg==2 .or. iflg==102)
write (61, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(9, i)
4993 if (iflg==12 .or. iflg==112)
write (61, 102) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(9, i)
4998 100
format (6(e13.6,1x))
4999 101
format (7(e13.6,1x))
5000 102
format (7(e13.6,1x))
5001 103
format (8(e13.6,1x))
5010 implicit real *8(a-h, o-z)
5011 common /gauss1/absg(40), wg(40), igaus
5012 common /randu/ck(15), kmax
5013 dimension ui(40), u9(9), u10(10), u12(12)
5014 dimension w9(9), w10(10), w12(12)
5016 data (u9(j), j=1, 9)/ -.9681602, -.8360311, -.6133714, -.3242534, 0., .3242534, .6133714, .8360311, .9681602/
5017 data (w9(j), j=1, 9)/.0812744, .1806482, .2606107, .3123471, .3302394, .3123471, .2606107, .1806482, .0812744/
5019 data (u10(j), j=1, 10)/ -.9739065, -.8650634, -.6794096, -.4333954, -.1488743, .1488743, .4333954, .6794096, &
5021 data (w10(j), j=1, 10)/.0666713, .1494513, .2190864, .2692667, .2955242, .2955242, .2692667, .2190864, .1494513, &
5024 data (u12(j), j=1, 12)/ -.9815606, -.9041173, -.7699027, -.5873180, -.3678315, -.1252334, .1252334, .3678315, &
5025 .5873180, .7699027, .9041173, .9815606/
5026 data (w12(j), j=1, 12)/.0471753, .1069393, .1600783, .2031674, .2334925, .2491470, .2491470, .2334925, .2031674, &
5027 .1600783, .1069393, .0471753/
5049 absg(i) = (1.+ui(i))/2.
5061 subroutine table(lbmax, mbmax, nbmax)
5062 implicit real *8(a-h, o-z)
5063 common /gauss1/absg(40), wg(40), igaus
5064 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
5065 common /expmod/ragp(40, 100), ragm1(40, 40)
5066 common /randu/ck(15), kmax
5067 common /hass/carg(100), sarg(100), argip(100)
5068 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
5069 common /consta/vl, pi, xmat, rpel, qst
5070 common /factor/fpir(40, 40), fect(30)
5075 if (lbmax>=ideg) ideg = lbmax
5076 if (mbmax>=ideg) ideg = mbmax
5090 co(i, j) = co(i, j-1)*cod
5091 sn(i, j) = sn(i, j-1)*snd
5096 idgp = 3*ideg + kmax
5101 absm2 = (1.-absg(i))*(1.-absg(i))
5103 ragp(i, j) = ragp(i, j-1)*absg(i)
5107 ragm1(i, j) = ragm1(i, j-1)*absm2
5111 carg(i) = sqrt((4.*float(i-1)+1.)/2.)
5112 sarg(i) = sqrt((4.*float(i-1)+3.)/2.)
5113 argip(i) = sqrt(2.*float(i-1)+1.)
5118 fpir(i, j) =
fper(i-1, j-1)
5129 end subroutine table 5135 implicit real *8(a-h, o-z)
5136 common /factor/fpir(40, 40), fect(30)
5149 implicit real *8(a-h, o-z)
5157 facj = facj*float(k)
5161 faci = faci*float(ii)
5172 implicit real *8(a-h, o-z)
5188 he(k+2) = s*he(k+1) - float(k)*he(k)
5190 hermint = he(ihd+1)*exp(-s*s/2.)
5198 implicit real *8(a-h, o-z)
5212 implicit real *8(a-h, o-z)
5216 if (m==0)
factd = 1.
5222 do k = 1, 2*m - 1, 2
5223 he(k+2) = -float(k)*he(k)
5239 implicit real *8(a-h, o-z)
5240 common /coef/a(30, 30, 30), xa, xb, xc
5241 common /ind/lmax, mmax, nmax
5242 common /indin/lmaxi, mmaxi, nmaxxi
5243 common /hcgrms/xcdg, ycdg, zcdg, ect, eps
5271 subroutine trms(isucc)
5272 implicit real *8(a-h, o-z)
5273 common /consta/vl, pi, xmat, rpel, qst
5274 common /coef/a(30, 30, 30), xa, xb, xc
5275 common /ind/lmax, mmax, nmax
5277 common /rms/rms(3, 50), s1, s2, s3
5278 common /gauss1/absg(40), wg(40), igaus
5279 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
5280 common /randu/ck(15), kmax
5283 if (rmin>xb) rmin = xb
5284 if (rmin>xc) rmin = xc
5286 if (rmin==xc) isucc = 3
5287 if (rmin==xb) isucc = 2
5288 if (rmin==xa) isucc = 1
5291 if (maxi<mmax) maxi = mmax
5292 if (maxi<nmax) maxi = nmax
5293 maxt = 2*(maxi+1) + 3
5320 rms(3, i) = rms(3, i-1)*x3
5321 rms(2, i) = rms(2, i-1)*x2
5322 rms(1, i) = rms(1, i-1)*x1
5328 im = i1m + i2m + i3m + j1 + 4
5330 write (16, *)
' overlap the array blam with im= ', im
5334 blam(i, 1) = (rms(1,3)*co(i,3)+rms(2,3)*sn(i,3))/rms(3, 3)
5336 blam(i, ii) = blam(i, ii-1)*blam(i, 1)
5347 implicit real *8(a-h, o-z)
5348 common /consta/vl, pi, xmat, rpel, qst
5349 common /rms/rms(3, 50), s1, s2, s3
5350 common /gauss1/absg(40), wg(40), igaus
5351 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
5352 common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
5353 common /expmod/ragp(40, 100), ragm1(40, 40)
5354 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
5355 common /ind/lmax, mmax, nmax
5356 common /indttal/lmnt
5357 common /randu/ck(15), kmax
5358 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
5360 common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
5361 common /herfun/hs1(60), hs2(60), hs3(60)
5371 if (s3<0.) sgns3 = -1.
5374 s1rms = s1*rms(1, 2)
5375 s2rms = s2*rms(2, 2)
5379 s3pw(i) = s3pw(i-1)*as3
5384 sqblam(ig) = sqrt(blam(ig,1))
5385 xlblam = sqblam(ig)*rms(3, 2)
5387 arghm1 = s1rms*co(ig, 2)/xlblam
5388 arghm2 = s2rms*sn(ig, 2)/xlblam
5390 arg = arghm1 + arghm2
5391 earg = exp(-arg*arg/2.)
5394 arg = arghm1 - arghm2
5395 earg = exp(-arg*arg/2.)
5397 hsint(ig, iarg, 1) = 1.*earg*wgpi
5398 hsint(ig, iarg, 2) = arg*earg*wgpi
5400 hsint(ig, iarg, inhs) = arg*hsint(ig, iarg, inhs-1) - float(inhs-2)*hsint(ig, iarg, inhs-2)
5404 r13 = rms(1, 2)/rms(3, 2)
5405 r23 = rms(2, 2)/rms(3, 2)
5408 aeps1 = ragp(i, 3)*(blam(j,1)-1.)/2.
5409 aeps1 = s32*(aeps1+ragp(i,2))
5410 aeps2 = ragp(i, 3)*blam(j, 1)/2.
5412 akc1 = ragp(i, 2)*r13*co(j, 2)*as31
5413 akc2 = ragp(i, 2)*r23*sn(j, 2)*as32
5414 aks1 = ragp(i, 2)*r13*co(j, 2)*as31
5415 aks2 = ragp(i, 2)*r23*sn(j, 2)*as32
5416 epsi1(i, j) = exp(-aeps1)*wg(i)
5417 epsi2(i, j) = exp(-aeps2)*wg(i)
5418 akpcc(i, j) = cos(akc1)*cos(akc2)
5419 akpcs(i, j) = cos(akc1)*sin(akc2)
5420 akpsc(i, j) = sin(akc1)*cos(akc2)
5421 akpss(i, j) = sin(akc1)*sin(akc2)
5432 hs1(ihe) = s1*hs1(ihe-1) - float(ihe-2)*hs1(ihe-2)
5433 hs2(ihe) = s2*hs2(ihe-1) - float(ihe-2)*hs2(ihe-2)
5434 hs3(ihe) = s3*hs3(ihe-1) - float(ihe-2)*hs3(ihe-2)
5437 end subroutine uvrms 5451 subroutine fielde(lc, mc, nc, isucc)
5452 implicit real *8(a-h, o-z)
5453 common /rms/rms(3, 50), s1, s2, s3
5454 common /partcl/x, y, z
5455 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
5456 common /field/ex, ey, ez
5457 common /randu/ck(15), kmax
5459 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
5462 common /sgpth/mksgi, mksgp
5463 common /ftth/makti, maktp
5464 common /fsth/maksi, maksp
5465 logical maksi, maksp
5466 logical makti, maktp
5467 logical mksgi, mksgp
5468 logical lpl, lpm, lpn
5480 tl = xlc - 2.*int(xlc/2.+0.0001)
5481 if (tl==0.) lpl = .true.
5483 tm = xmc - 2.*int(xmc/2.+0.0001)
5484 if (tm==0.) lpm = .true.
5486 tn = xnc - 2.*int(xnc/2.+0.0001)
5487 if (tn==0.) lpn = .true.
5488 if (lpl .and. lpm .and. lpn) itpar = 1
5489 if (lpl .and. lpm .and. .not. lpn) itpar = 2
5490 if (lpl .and. .not. lpm .and. lpn) itpar = 3
5491 if (lpl .and. .not. lpm .and. .not. lpn) itpar = 4
5492 if (.not. lpl .and. lpm .and. lpn) itpar = 5
5493 if (.not. lpl .and. lpm .and. .not. lpn) itpar = 6
5494 if (.not. lpl .and. .not. lpm .and. lpn) itpar = 7
5495 if (.not. lpl .and. .not. lpm .and. .not. lpn) itpar = 8
5512 it = lc + mc + nc + 1
5515 ex =
eipp(it1, it2, it3)
5516 ey =
epip(it1, it2, it3)
5517 ez =
eppi(it1, it2, it3)
5535 ex =
eipi(it1, it2, it3)
5536 ey =
epii(it1, it2, it3)
5539 if (s3/=0.) pwas3 = pwas3*s32
5541 ez =
eppp(it1, it2, it3)
5560 ex =
eiip(it1, it2, it3)
5566 if (s3/=0.) pwas3 = pwas3*s32
5567 ey =
eppp(it1, it2, it3)
5572 if (s3/=0.) pwas3 = apwas3
5574 ez =
epii(it1, it2, it3)
5589 it = lc + mc + nc - 1
5592 ex =
eiii(it1, it2, it3)
5598 if (s3/=0.) pwas3 = pwas3*s32
5599 ey =
eppi(it1, it2, it3)
5604 ez =
epip(it1, it2, it3)
5623 ex =
eppp(it1, it2, it3)
5633 ey =
eiip(it1, it2, it3)
5638 ez =
eipi(it1, it2, it3)
5653 it = lc + mc + nc - 1
5657 ex =
eppi(it1, it2, it3)
5666 ey =
eiii(it1, it2, it3)
5672 if (s3/=0.) pwas3 = pwas3*s32
5673 ez =
eipp(it1, it2, it3)
5688 it = lc + mc + nc - 1
5692 ex =
epip(it1, it2, it3)
5698 ey =
eipp(it1, it2, it3)
5704 if (s3/=0.) pwas3 = apwas3
5705 ez =
eiii(it1, it2, it3)
5723 ex =
epii(it1, it2, it3)
5729 ey =
eipi(it1, it2, it3)
5734 ez =
eiip(it1, it2, it3)
5752 it = mc + nc + lc + 1
5755 ex =
eppi(it1, it2, it3)
5756 ey =
eipp(it1, it2, it3)
5757 ez =
epip(it1, it2, it3)
5775 ex =
epii(it1, it2, it3)
5776 ey =
eiip(it1, it2, it3)
5780 if (s3/=0.) pwas3 = pwas3*s32
5781 ez =
eppp(it1, it2, it3)
5800 ex =
eipi(it1, it2, it3)
5809 ey =
eppp(it1, it2, it3)
5814 if (s3/=0.) pwas3 = apwas3
5815 ez =
eiip(it1, it2, it3)
5830 it = mc + nc + lc - 1
5833 ex =
eiii(it1, it2, it3)
5842 ey =
epip(it1, it2, it3)
5848 ez =
eipp(it1, it2, it3)
5867 ex =
eppp(it1, it2, it3)
5873 if (s3/=0.) pwas3 = apwas3
5874 ey =
eipi(it1, it2, it3)
5879 ez =
epii(it1, it2, it3)
5894 it = mc + nc + lc - 1
5898 ex =
epip(it1, it2, it3)
5904 if (s3/=0.) pwas3 = apwas3
5905 ey =
eiii(it1, it2, it3)
5911 if (s3/=0.) pwas3 = apwas3*s32
5912 ez =
eppi(it1, it2, it3)
5927 it = mc + nc + lc - 1
5931 ex =
eipp(it1, it2, it3)
5937 ey =
eppi(it1, it2, it3)
5942 if (s3/=0.) pwas3 = apwas3
5944 ez =
eiii(it1, it2, it3)
5962 ex =
eiip(it1, it2, it3)
5968 ey =
epii(it1, it2, it3)
5974 ez =
eipi(it1, it2, it3)
5992 it = nc + lc + mc + 1
5995 ex =
epip(it1, it2, it3)
5996 ey =
eppi(it1, it2, it3)
5997 ez =
eipp(it1, it2, it3)
6015 ex =
eiip(it1, it2, it3)
6016 ey =
eipi(it1, it2, it3)
6019 if (s3/=0.) pwas3 = pwas3*s32
6021 ez =
eppp(it1, it2, it3)
6040 ex =
epii(it1, it2, it3)
6046 if (s3/=0.) pwas3 = pwas3*s32
6047 ey =
eppp(it1, it2, it3)
6052 if (s3/=0.) pwas3 = apwas3
6053 ez =
eipi(it1, it2, it3)
6068 it = nc + lc + mc - 1
6071 ex =
eiii(it1, it2, it3)
6077 if (s3/=0.) pwas3 = pwas3*s32
6078 ey =
eipp(it1, it2, it3)
6084 ez =
eppi(it1, it2, it3)
6103 ex =
eppp(it1, it2, it3)
6109 if (s3/=0.) pwas3 = apwas3
6110 ey =
epii(it1, it2, it3)
6115 ez =
eiip(it1, it2, it3)
6130 it = nc + lc + mc - 1
6134 ex =
eipp(it1, it2, it3)
6140 if (s3/=0.) pwas3 = apwas3
6141 ey =
eiii(it1, it2, it3)
6147 if (s3/=0.) pwas3 = pwas3*s32
6148 ez =
epip(it1, it2, it3)
6163 it = nc + lc + mc - 1
6167 ex =
eppi(it1, it2, it3)
6173 ey =
epip(it1, it2, it3)
6179 if (s3/=0.) pwas3 = apwas3
6180 ez =
eiii(it1, it2, it3)
6198 ex =
eipi(it1, it2, it3)
6204 ey =
eiip(it1, it2, it3)
6210 ez =
eppi(it1, it2, it3)
6220 function eppp(it1, it2, it3)
6221 implicit real *8(a-h, o-z)
6222 common /rms/rms(3, 50), s1, s2, s3
6223 common /partcl/x, y, z
6224 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6226 common /randu/ck(15), kmax
6227 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6231 isgnw = 4*(it2+it1) + 5*it3
6232 ipar = isgnw - 2*(isgnw/2)
6234 if (ipar==0) wsng = 1.
6235 eppp = wsng*pi2*exs3*rms(3, 3)
6241 isgn1 = 3*(it1+it2) + 4*it3
6242 ipar = isgn1 - 2*(isgn1/2)
6249 ipt212 = 2*(it1+it2)
6250 rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
6251 e1 = 2.*sgn1*pi2*pwas3*rint*
uppp(it1, it2, it3)
6256 scum = scum + ck(k)*pcas3*
vppp(kj)
6260 e2 = scum*sgn2*2.*pi2*rint*exs3
6269 function epip(it1, it2, it3)
6270 implicit real *8(a-h, o-z)
6271 common /rms/rms(3, 50), s1, s2, s3
6272 common /partcl/x, y, z
6273 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6274 common /randu/ck(15), kmax
6276 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6280 isgnw = 4*(it2+it1) + 5*it3 + 2
6281 ipar = isgnw - 2*(isgnw/2)
6283 if (ipar==0) wsng = 1.
6284 epip = wsng*pi2*exs3*rms(3, 3)
6291 isgn1 = 3*(it1+it2) + 4*it3 + 2
6292 ipar = isgn1 - 2*(isgn1/2)
6299 ipt212 = 2*(it1+it2) + 1
6300 rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
6301 e1 = 2.*sgn1*pi2*pwas31*rint*
upip(it1, it2, it3)
6306 scum = scum + ck(k)*pcas3*
vpip(kj)
6310 e2 = scum*sgn2*2.*pi2*rint*exs3
6319 function eppi(it1, it2, it3)
6320 implicit real *8(a-h, o-z)
6321 common /rms/rms(3, 50), s1, s2, s3
6322 common /partcl/x, y, z
6323 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6324 common /randu/ck(15), kmax
6325 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6329 isgnw = 4*(it2+it1) + 5*it3 + 2
6330 ipar = isgnw - 2*(isgnw/2)
6332 if (ipar==0) wsng = 1.
6333 eppi = wsng*pi2*exs3*rms(3, 3)
6340 isgn1 = 3*(it1+it2) + 4*it3 + 2
6342 pari = xsgn1 - 2.*int(xsgn1/2.+0.0001)
6349 ipt212 = 2*(it1+it2) + 1
6350 rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
6351 e1 = 2.*sgn1*pi2*pwas31*rint*
uppi(it1, it2, it3)
6356 scum = scum + ck(k)*pcas3*
vppi(kj)
6360 e2 = scum*sgn2*2.*pi2*rint*exs3
6369 function epii(it1, it2, it3)
6370 implicit real *8(a-h, o-z)
6371 common /rms/rms(3, 50), s1, s2, s3
6372 common /partcl/x, y, z
6373 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6374 common /randu/ck(15), kmax
6376 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6380 isgnw = 4*(it2+it1) + 5*it3 + 4
6381 ipar = isgnw - 2*(isgnw/2)
6383 if (ipar==0) wsng = 1.
6384 epii = wsng*pi2*exs3*rms(3, 3)
6391 isgn1 = 3*(it1+it2) + 4*it3 + 4
6392 ipar = isgn1 - 2*(isgn1/2)
6399 ipt212 = 2*(it1+it2+1)
6400 rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
6401 e1 = 2.*sgn1*pi2*pwas31*rint*
upii(it1, it2, it3)
6406 scum = scum + ck(k)*pcas3*
vpii(kj)
6410 e2 = scum*sgn2*2.*pi2*rint*exs3
6419 function eipp(it1, it2, it3)
6420 implicit real *8(a-h, o-z)
6421 common /rms/rms(3, 50), s1, s2, s3
6422 common /partcl/x, y, z
6423 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6424 common /randu/ck(15), kmax
6426 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6430 isgnw = 4*(it2+it1) + 5*it3 + 3
6431 ipar = isgnw - 2*(isgnw/2)
6433 if (ipar==0) wsng = 1.
6434 eipp = wsng*sgns3*pi2*exs3*rms(3, 3)
6441 isgn1 = 3*(it1+it2) + 4*it3 + 3
6442 ipar = isgn1 - 2*(isgn1/2)
6449 ipt212 = 2*(it1+it2)
6450 rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
6451 e1 = 2.*sgn1*pi2*pwas31*rint*
uipp(it1, it2, it3)*sgns3
6456 scum = scum + ck(k)*pcas3*
vipp(kj)
6460 e2 = scum*sgn2*2.*pi2*rint*exs3*sgns3
6469 function eiip(it1, it2, it3)
6470 implicit real *8(a-h, o-z)
6471 common /rms/rms(3, 50), s1, s2, s3
6472 common /partcl/x, y, z
6473 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6474 common /randu/ck(15), kmax
6476 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6480 isgnw = 4*(it2+it1) + 5*it3 + 5
6481 ipar = isgnw - 2*(isgnw/2)
6483 if (ipar==0) wsng = 1.
6484 eiip = wsng*sgns3*pi2*exs3*rms(3, 3)
6491 isgn1 = 3*(it1+it2) + 4*it3 + 5
6492 ipar = isgn1 - 2*(isgn1/2)
6499 ipt212 = 2*(it1+it2) + 1
6500 rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
6501 e1 = 2.*sgn1*pi2*pwas31*rint*
uiip(it1, it2, it3)*sgns3
6506 scum = scum + ck(k)*pcas3*
viip(kj)
6510 e2 = scum*sgn2*2.*pi2*rint*exs3*sgns3
6519 function eipi(it1, it2, it3)
6520 implicit real *8(a-h, o-z)
6521 common /rms/rms(3, 50), s1, s2, s3
6522 common /partcl/x, y, z
6523 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6524 common /randu/ck(15), kmax
6526 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6530 isgnw = 4*(it2+it1) + 5*it3 + 5
6531 ipar = isgnw - 2*(isgnw/2)
6533 if (ipar==0) wsng = 1.
6534 eipi = wsng*sgns3*pi2*exs3*rms(3, 3)
6541 isgn1 = 3*(it1+it2) + 4*it3 + 5
6542 ipar = isgn1 - 2*(isgn1/2)
6549 ipt212 = 2*(it1+it2) + 1
6550 rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
6551 e1 = 2.*sgn1*pi2*pwas31*rint*
uipi(it1, it2, it3)*sgns3
6556 scum = scum + ck(k)*pcas3*
vipi(kj)
6560 e2 = scum*sgn2*2.*pi2*rint*exs3*sgns3
6569 function eiii(it1, it2, it3)
6570 implicit real *8(a-h, o-z)
6571 common /rms/rms(3, 50), s1, s2, s3
6572 common /partcl/x, y, z
6573 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6574 common /randu/ck(15), kmax
6576 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6580 isgnw = 4*(it2+it1) + 5*it3 + 5
6581 ipar = isgnw - 2*(isgnw/2)
6583 if (ipar==0) wsng = 1.
6584 eiii = wsng*sgns3*pi2*exs3*rms(3, 3)
6588 pwas31 = pwas3*s32*as3
6591 isgn1 = 3*(it1+it2) + 4*it3 + 5
6592 ipar = isgn1 - 2*(isgn1/2)
6599 ipt212 = 2*(it1+it2) + 2
6600 rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
6601 e1 = 2.*sgn1*pi2*pwas31*rint*
uiii(it1, it2, it3)*sgns3
6606 scum = scum + ck(k)*pcas3*
viii(kj)
6610 e2 = scum*sgn2*2.*pi2*rint*exs3*sgns3
6620 function tipp(it1, it2, it3)
6621 implicit real *8(a-h, o-z)
6622 common /randu/ck(15), kmax
6623 common /gauss1/absg(40), wg(40), igaus
6624 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
6625 common /rms/rms(3, 50), s1, s2, s3
6626 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6627 common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
6628 common /herfun/hs1(60), hs2(60), hs3(60)
6629 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6630 common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
6631 common /ftth/makti, maktp
6632 logical makti, maktp
6635 if (.not. makti)
then 6652 stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
6653 stc1i(kk, jj1, mm) =
fpar(it3j1, mm1)/stoc
6654 it23jm = 2*(it2+it3+jm1-mm1)
6656 tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+1)
6660 stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
6661 stc2i(kk, jj1) = 2.*
fpar(km1, 2*jm1)*stoc
6662 tt1 = tt1 + tt*stc2i(kk, jj1)
6686 it23jm = 2*(it2+it3+jm1-mm1)
6688 tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+1)
6691 tt1 = tt1 + tt*stc2i(kk, jj1)
6706 function tiip(it1, it2, it3)
6707 implicit real *8(a-h, o-z)
6708 common /randu/ck(15), kmax
6709 common /gauss1/absg(40), wg(40), igaus
6710 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
6711 common /rms/rms(3, 50), s1, s2, s3
6712 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6713 common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
6714 common /herfun/hs1(60), hs2(60), hs3(60)
6715 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6716 common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
6717 common /ftth/makti, maktp
6718 logical makti, maktp
6721 if (.not. makti)
then 6737 stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
6738 stc1i(kk, jj1, mm) =
fpar(it3j1, mm1)/stoc
6739 it23jm = 2*(it2+it3+jm1-mm1)
6741 tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+1)
6745 stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
6746 stc2i(kk, jj1) = 2.*
fpar(km1, 2*jm1)*stoc
6747 tt1 = tt1 + tt*stc2i(kk, jj1)
6771 it23jm = 2*(it2+it3+jm1-mm1)
6773 tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+1)
6776 tt1 = tt1 + tt*stc2i(kk, jj1)
6791 function tipi(it1, it2, it3)
6792 implicit real *8(a-h, o-z)
6793 common /randu/ck(15), kmax
6794 common /gauss1/absg(40), wg(40), igaus
6795 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
6796 common /rms/rms(3, 50), s1, s2, s3
6797 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6798 common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
6799 common /herfun/hs1(60), hs2(60), hs3(60)
6800 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6801 common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
6802 common /ftth/makti, maktp
6803 logical makti, maktp
6806 if (.not. makti)
then 6823 stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
6824 stc1i(kk, jj1, mm) =
fpar(it3j1, mm1)/stoc
6825 it23jm = 2*(it2+it3+jm1-mm1)
6827 tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+2)
6831 stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
6832 stc2i(kk, jj1) = 2.*
fpar(km1, 2*jm1)*stoc
6833 tt1 = tt1 + tt*stc2i(kk, jj1)
6857 it23jm = 2*(it2+it3+jm1-mm1)
6859 tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+2)
6862 tt1 = tt1 + tt*stc2i(kk, jj1)
6877 function tiii(it1, it2, it3)
6878 implicit real *8(a-h, o-z)
6879 common /randu/ck(15), kmax
6880 common /gauss1/absg(40), wg(40), igaus
6881 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
6882 common /rms/rms(3, 50), s1, s2, s3
6883 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6884 common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
6885 common /herfun/hs1(60), hs2(60), hs3(60)
6886 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6887 common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
6888 common /ftth/makti, maktp
6889 logical makti, maktp
6892 if (.not. makti)
then 6909 stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
6910 stc1i(kk, jj1, mm) =
fpar(it3j1, mm1)/stoc
6911 it23jm = 2*(it2+it3+jm1-mm1)
6913 tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+2)
6917 stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
6918 stc2i(kk, jj1) = 2.*
fpar(km1, 2*jm1)*stoc
6919 tt1 = tt1 + tt*stc2i(kk, jj1)
6943 it23jm = 2*(it2+it3+jm1-mm1)
6945 tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+2)
6948 tt1 = tt1 + tt*stc2i(kk, jj1)
6963 function tppp(it1, it2, it3)
6964 implicit real *8(a-h, o-z)
6965 common /randu/ck(15), kmax
6966 common /gauss1/absg(40), wg(40), igaus
6967 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
6968 common /rms/rms(3, 50), s1, s2, s3
6969 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6970 common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
6971 common /herfun/hs1(60), hs2(60), hs3(60)
6972 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6973 common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
6974 common /ftth/makti, maktp
6975 logical makti, maktp
6978 if (.not. maktp)
then 6988 j1km = km1 - 2*jm1 - 1
6990 if (j1km<0)
go to 100
6997 stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
6998 stc1p(kk, jj1, mm) =
fpar(it3j1, mm1)/stoc
6999 it23jm = 2*(it2+it3+jm1-mm1)
7001 tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+1)
7005 stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
7006 stc2p(kk, jj1) = 2.*
fpar(km1, 2*jm1+1)*stoc
7007 tt1 = tt1 + tt*stc2p(kk, jj1)
7025 j1km = km1 - 2*jm1 - 1
7027 if (j1km<0)
go to 200
7034 it23jm = 2*(it2+it3+jm1-mm1)
7036 tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+1)
7039 tt1 = tt1 + tt*stc2p(kk, jj1)
7055 function tpip(it1, it2, it3)
7056 implicit real *8(a-h, o-z)
7057 common /randu/ck(15), kmax
7058 common /gauss1/absg(40), wg(40), igaus
7059 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7060 common /rms/rms(3, 50), s1, s2, s3
7061 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7062 common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7063 common /herfun/hs1(60), hs2(60), hs3(60)
7064 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7065 common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
7066 common /ftth/makti, maktp
7067 logical makti, maktp
7070 if (.not. maktp)
then 7080 j1km = km1 - 2*jm1 - 1
7082 if (j1km<0)
go to 100
7089 stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
7090 stc1p(kk, jj1, mm) =
fpar(it3j1, mm1)/stoc
7091 it23jm = 2*(it2+it3+jm1-mm1)
7093 tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+1)
7097 stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
7098 stc2p(kk, jj1) = 2.*
fpar(km1, 2*jm1+1)*stoc
7099 tt1 = tt1 + tt*stc2p(kk, jj1)
7117 j1km = km1 - 2*jm1 - 1
7119 if (j1km<0)
go to 200
7126 it23jm = 2*(it2+it3+jm1-mm1)
7128 tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+1)
7131 tt1 = tt1 + tt*stc2p(kk, jj1)
7147 function tppi(it1, it2, it3)
7148 implicit real *8(a-h, o-z)
7149 common /randu/ck(15), kmax
7150 common /gauss1/absg(40), wg(40), igaus
7151 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7152 common /rms/rms(3, 50), s1, s2, s3
7153 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7154 common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7155 common /herfun/hs1(60), hs2(60), hs3(60)
7156 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7157 common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
7158 common /ftth/makti, maktp
7159 logical makti, maktp
7162 if (.not. maktp)
then 7172 j1km = km1 - 2*jm1 - 1
7174 if (j1km<0)
go to 100
7181 stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
7182 stc1p(kk, jj1, mm) =
fpar(it3j1, mm1)/stoc
7183 it23jm = 2*(it2+it3+jm1-mm1)
7185 tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+2)
7189 stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
7190 stc2p(kk, jj1) = 2.*
fpar(km1, 2*jm1+1)*stoc
7191 tt1 = tt1 + tt*stc2p(kk, jj1)
7209 j1km = km1 - 2*jm1 - 1
7211 if (j1km<0)
go to 200
7218 it23jm = 2*(it2+it3+jm1-mm1)
7220 tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+2)
7223 tt1 = tt1 + tt*stc2p(kk, jj1)
7239 function tpii(it1, it2, it3)
7240 implicit real *8(a-h, o-z)
7241 common /randu/ck(15), kmax
7242 common /gauss1/absg(40), wg(40), igaus
7243 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7244 common /rms/rms(3, 50), s1, s2, s3
7245 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7246 common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7247 common /herfun/hs1(60), hs2(60), hs3(60)
7248 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7249 common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
7250 common /ftth/makti, maktp
7251 logical makti, maktp
7254 if (.not. maktp)
then 7264 j1km = km1 - 2*jm1 - 1
7266 if (j1km<0)
go to 100
7273 stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
7274 stc1p(kk, jj1, mm) =
fpar(it3j1, mm1)/stoc
7275 it23jm = 2*(it2+it3+jm1-mm1)
7277 tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+2)
7281 stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
7282 stc2p(kk, jj1) = 2.*
fpar(km1, 2*jm1+1)*stoc
7283 tt1 = tt1 + tt*stc2p(kk, jj1)
7301 j1km = km1 - 2*jm1 - 1
7303 if (j1km<0)
go to 200
7310 it23jm = 2*(it2+it3+jm1-mm1)
7312 tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+2)
7315 tt1 = tt1 + tt*stc2p(kk, jj1)
7331 function sipp(it1, it2, it3)
7332 implicit real *8(a-h, o-z)
7333 common /consta/vl, pi, xmat, rpel, qst
7334 common /randu/ck(15), kmax
7335 common /gauss1/absg(40), wg(40), igaus
7336 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7337 common /rms/rms(3, 50), s1, s2, s3
7338 common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7339 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7340 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7341 common /hass/carg(100), sarg(100), argip(100)
7342 common /fssk/sstci(8, 8), sstcp(8, 8)
7343 common /fsth/maksi, maksp
7344 logical maksi, maksp
7349 it12p = 2*(it1+it2+1) + 1
7350 bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
7361 if (j1km<0)
go to 100
7364 i1123j1 = it1 + it2 + it3 + jm1 + 1
7371 base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1)
7372 htm0 = hsint(ig, 2, i2123j1+1)
7373 htp0 = hsint(ig, 1, i2123j1+1)
7374 tt = tt + base/sqblam(ig)*(htm0+htp0)
7376 if (.not. maksi)
then 7378 stock = 2.*xsj1*s3pw(j1km+1)
7379 sstci(kk, jj2) =
fpar(km1, jj1)*stock
7382 tt1 = sstci(kk, jj2)*tt + tt1
7400 function siip(it1, it2, it3)
7401 implicit real *8(a-h, o-z)
7402 common /consta/vl, pi, xmat, rpel, qst
7403 common /randu/ck(15), kmax
7404 common /gauss1/absg(40), wg(40), igaus
7405 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7406 common /rms/rms(3, 50), s1, s2, s3
7407 common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7408 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7409 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7410 common /fssk/sstci(8, 8), sstcp(8, 8)
7411 common /fsth/maksi, maksp
7412 logical maksi, maksp
7417 it12p = 2*(it1+it2+2)
7418 bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
7429 if (j1km<0)
go to 100
7432 i1123j1 = it1 + it2 + it3 + jm1 + 2
7433 i2123j1 = 2*i1123j1 - 1
7437 base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1)
7438 htm0 = hsint(ig, 2, i2123j1+1)
7439 htp0 = hsint(ig, 1, i2123j1+1)
7440 tt = tt + base*(htp0-htm0)
7442 if (.not. maksi)
then 7444 stock = 2.*xsj1*s3pw(j1km+1)
7445 sstci(kk, jj2) =
fpar(km1, jj1)*stock
7448 tt1 = sstci(kk, jj2)*tt + tt1
7466 function sipi(it1, it2, it3)
7467 implicit real *8(a-h, o-z)
7468 common /consta/vl, pi, xmat, rpel, qst
7469 common /randu/ck(15), kmax
7470 common /gauss1/absg(40), wg(40), igaus
7471 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7472 common /rms/rms(3, 50), s1, s2, s3
7473 common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7474 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7475 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7476 common /fssk/sstci(8, 8), sstcp(8, 8)
7477 common /fsth/maksi, maksp
7478 logical maksi, maksp
7483 it12p = 2*(it1+it2+2)
7484 bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
7495 if (j1km<0)
go to 100
7498 i1123j1 = it1 + it2 + it3 + jm1 + 2
7499 i2123j1 = 2*i1123j1 - 1
7503 base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1)
7504 htm0 = hsint(ig, 2, i2123j1+1)
7505 htp0 = hsint(ig, 1, i2123j1+1)
7506 tt = tt + base*(htp0+htm0)
7508 if (.not. maksi)
then 7510 stock = 2.*xsj1*s3pw(j1km+1)
7511 sstci(kk, jj2) =
fpar(km1, jj1)*stock
7514 tt1 = sstci(kk, jj2)*tt + tt1
7532 function siii(it1, it2, it3)
7533 implicit real *8(a-h, o-z)
7534 common /consta/vl, pi, xmat, rpel, qst
7535 common /randu/ck(15), kmax
7536 common /gauss1/absg(40), wg(40), igaus
7537 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7538 common /rms/rms(3, 50), s1, s2, s3
7539 common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7540 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7541 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7542 common /fssk/sstci(8, 8), sstcp(8, 8)
7543 common /fsth/maksi, maksp
7544 logical maksi, maksp
7549 it12p = 2*(it1+it2+2) + 1
7550 bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
7561 if (j1km<0)
go to 100
7564 i1123j1 = it1 + it2 + it3 + jm1 + 2
7569 base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1)
7570 htm0 = hsint(ig, 2, i2123j1+1)
7571 htp0 = hsint(ig, 1, i2123j1+1)
7572 tt = tt + base*(htm0-htp0)/sqblam(ig)
7574 if (.not. maksi)
then 7576 stock = 2.*xsj1*s3pw(j1km+1)
7577 sstci(kk, jj2) =
fpar(km1, jj1)*stock
7580 tt1 = sstci(kk, jj2)*tt + tt1
7598 function sppp(it1, it2, it3)
7599 implicit real *8(a-h, o-z)
7600 common /consta/vl, pi, xmat, rpel, qst
7601 common /randu/ck(15), kmax
7602 common /gauss1/absg(40), wg(40), igaus
7603 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7604 common /rms/rms(3, 50), s1, s2, s3
7605 common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7606 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7607 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7608 common /fssk/sstci(8, 8), sstcp(8, 8)
7609 common /fsth/maksi, maksp
7610 logical maksi, maksp
7615 it12p = 2*(it1+it2+1) + 1
7616 bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
7626 if (j1km<0)
go to 100
7629 i1123j1 = it1 + it2 + it3 + jm1
7634 base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1)
7635 htm0 = hsint(ig, 2, i2123j1+1)
7636 htp0 = hsint(ig, 1, i2123j1+1)
7637 tt = tt + base*(htm0+htp0)/sqblam(ig)
7639 if (.not. maksp)
then 7641 stock = 2.*xsj1*s3pw(j1km+1)
7642 sstcp(kk, jj1) =
fpar(km1, 2*jm1)*stock
7645 tt1 = sstcp(kk, jj1)*tt + tt1
7663 function spip(it1, it2, it3)
7664 implicit real *8(a-h, o-z)
7665 common /consta/vl, pi, xmat, rpel, qst
7666 common /randu/ck(15), kmax
7667 common /gauss1/absg(40), wg(40), igaus
7668 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7669 common /rms/rms(3, 50), s1, s2, s3
7670 common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7671 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7672 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7673 common /fssk/sstci(8, 8), sstcp(8, 8)
7674 common /fsth/maksi, maksp
7675 logical maksi, maksp
7680 it12p = 2*(it1+it2+1) + 2
7681 bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
7691 if (j1km<0)
go to 100
7694 i1123j1 = it1 + it2 + it3 + jm1
7695 i2123j1 = 2*i1123j1 + 1
7699 base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1+1)
7700 htm0 = hsint(ig, 2, i2123j1+1)
7701 htp0 = hsint(ig, 1, i2123j1+1)
7702 tt = tt + base*(htp0-htm0)
7704 if (.not. maksp)
then 7706 stock = 2.*xsj1*s3pw(j1km+1)
7707 sstcp(kk, jj1) =
fpar(km1, 2*jm1)*stock
7710 tt1 = sstcp(kk, jj1)*tt + tt1
7728 function sppi(it1, it2, it3)
7729 implicit real *8(a-h, o-z)
7730 common /consta/vl, pi, xmat, rpel, qst
7731 common /randu/ck(15), kmax
7732 common /gauss1/absg(40), wg(40), igaus
7733 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7734 common /rms/rms(3, 50), s1, s2, s3
7735 common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7736 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7737 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7738 common /fssk/sstci(8, 8), sstcp(8, 8)
7739 common /fsth/maksi, maksp
7740 logical maksi, maksp
7745 it12p = 2*(it1+it2+1) + 2
7746 bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
7757 if (j1km<0)
go to 100
7759 i1123j1 = it1 + it2 + it3 + jm1
7760 i2123j1 = 2*i1123j1 + 1
7764 base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1+1)
7765 htm0 = hsint(ig, 2, i2123j1+1)
7766 htp0 = hsint(ig, 1, i2123j1+1)
7767 tt = tt + base*(htm0+htp0)
7769 if (.not. maksp)
then 7771 stock = 2.*xsj1*s3pw(j1km+1)
7772 sstcp(kk, jj1) =
fpar(km1, 2*jm1)*stock
7775 tt1 = sstcp(kk, jj1)*tt + tt1
7793 function spii(it1, it2, it3)
7794 implicit real *8(a-h, o-z)
7795 common /consta/vl, pi, xmat, rpel, qst
7796 common /randu/ck(15), kmax
7797 common /gauss1/absg(40), wg(40), igaus
7798 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7799 common /rms/rms(3, 50), s1, s2, s3
7800 common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7801 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7802 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7803 common /fssk/sstci(8, 8), sstcp(8, 8)
7804 common /fsth/maksi, maksp
7805 logical maksi, maksp
7810 it12p = 2*(it1+it2+2) + 1
7811 bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
7821 if (j1km<0)
go to 100
7824 i1123j1 = it1 + it2 + it3 + jm1
7825 i2123j1 = 2*i1123j1 + 2
7829 base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1+1)
7830 htm0 = hsint(ig, 2, i2123j1+1)
7831 htp0 = hsint(ig, 1, i2123j1+1)
7832 tt = tt + base*(htm0-htp0)/sqblam(ig)
7834 if (.not. maksp)
then 7836 stock = 2.*xsj1*s3pw(j1km+1)
7837 sstcp(kk, jj1) =
fpar(km1, 2*jm1)*stock
7840 tt1 = sstcp(kk, jj1)*tt + tt1
7865 function sgppp(it1, it2, it3)
7866 implicit real *8(a-h, o-z)
7867 common /rms/rms(3, 50), s1, s2, s3
7868 common /herfun/hs1(60), hs2(60), hs3(60)
7869 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7870 common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
7871 common /sgpth/mksgi, mksgp
7872 logical mksgi, mksgp
7877 if (.not. mksgp)
then 7882 it3kp1 = it3 - ik + 1
7884 sgp3(ik) = sgn*hs3(km2+1)*rms(3, it3k+1)
7887 jt3kj = 2*(it3-ik-jkm1)
7888 jt23kj = 2*(it3+it2-ik-jkm1)
7890 stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
7891 sgrp(ik, jk) =
fpar(it3-ik, jkm1)/stoc
7892 sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+1)
7901 it3kp1 = it3 - ik + 1
7904 jt23kj = 2*(it3+it2-ik-jkm1)
7906 sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+1)
7918 function sgpip(it1, it2, it3)
7919 implicit real *8(a-h, o-z)
7920 common /rms/rms(3, 50), s1, s2, s3
7921 common /herfun/hs1(60), hs2(60), hs3(60)
7922 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7923 common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
7924 common /sgpth/mksgi, mksgp
7925 logical mksgi, mksgp
7930 if (.not. mksgp)
then 7935 it3kp1 = it3 - ik + 1
7938 sgp3(ik) = sgn*hs3(km2+1)*rms(3, it3k+1)
7941 jt3kj = 2*(it3-ik-jkm1)
7942 jt23kj = 2*(it3+it2-ik-jkm1)
7944 stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
7945 sgrp(ik, jk) =
fpar(it3-ik, jkm1)/stoc
7946 sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+1)
7955 it3kp1 = it3 - ik + 1
7958 jt23kj = 2*(it3+it2-ik-jkm1)
7960 sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+1)
7972 function sgppi(it1, it2, it3)
7973 implicit real *8(a-h, o-z)
7974 common /rms/rms(3, 50), s1, s2, s3
7975 common /herfun/hs1(60), hs2(60), hs3(60)
7976 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7977 common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
7978 common /sgpth/mksgi, mksgp
7979 logical mksgi, mksgp
7984 if (.not. mksgp)
then 7989 it3kp1 = it3 - ik + 1
7991 sgp3(ik) = sgn*hs3(km2+1)*rms(3, it3k+1)
7994 jt3kj = 2*(it3-ik-jkm1)
7995 jt23kj = 2*(it3+it2-ik-jkm1)
7997 stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
7998 sgrp(ik, jk) =
fpar(it3-ik, jkm1)/stoc
7999 sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+2)
8008 it3kp1 = it3 - ik + 1
8011 jt23kj = 2*(it3+it2-ik-jkm1)
8013 sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+2)
8025 function sgpii(it1, it2, it3)
8026 implicit real *8(a-h, o-z)
8027 common /rms/rms(3, 50), s1, s2, s3
8028 common /herfun/hs1(60), hs2(60), hs3(60)
8029 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
8030 common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
8031 common /sgpth/mksgi, mksgp
8032 logical mksgi, mksgp
8037 if (.not. mksgp)
then 8042 it3kp1 = it3 - ik + 1
8044 sgp3(ik) = sgn*hs3(km2+1)*rms(3, it3k+1)
8047 jt3kj = 2*(it3-ik-jkm1)
8048 jt23kj = 2*(it3+it2-ik-jkm1)
8050 stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
8051 sgrp(ik, jk) =
fpar(it3-ik, jkm1)/stoc
8052 sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+2)
8061 it3kp1 = it3 - ik + 1
8064 jt23kj = 2*(it3+it2-ik-jkm1)
8066 sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+2)
8078 function sgipp(it1, it2, it3)
8079 implicit real *8(a-h, o-z)
8080 common /rms/rms(3, 50), s1, s2, s3
8081 common /herfun/hs1(60), hs2(60), hs3(60)
8082 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
8083 common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
8084 common /sgpth/mksgi, mksgp
8085 logical mksgi, mksgp
8090 if (.not. mksgi)
then 8095 it3kp1 = it3 - ik + 1
8097 sgi3(ik) = sgn*hs3(km1+1)*rms(3, it3k+1)
8100 jt3kj = 2*(it3-ik-jkm1)
8101 jt23kj = 2*(it3+it2-ik-jkm1)
8103 stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
8104 sgri(ik, jk) =
fpar(it3-ik, jkm1)/stoc
8105 sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+1)
8114 it3kp1 = it3 - ik + 1
8117 jt23kj = 2*(it3+it2-ik-jkm1)
8119 sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+1)
8131 function sgiip(it1, it2, it3)
8132 implicit real *8(a-h, o-z)
8133 common /rms/rms(3, 50), s1, s2, s3
8134 common /herfun/hs1(60), hs2(60), hs3(60)
8135 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
8136 common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
8137 common /sgpth/mksgi, mksgp
8138 logical mksgi, mksgp
8143 if (.not. mksgi)
then 8148 it3kp1 = it3 - ik + 1
8150 sgi3(ik) = sgn*hs3(km1+1)*rms(3, it3k+1)
8153 jt3kj = 2*(it3-ik-jkm1)
8154 jt23kj = 2*(it3+it2-ik-jkm1)
8156 stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
8157 sgri(ik, jk) =
fpar(it3-ik, jkm1)/stoc
8158 sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+1)
8167 it3kp1 = it3 - ik + 1
8170 jt23kj = 2*(it3+it2-ik-jkm1)
8172 sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+1)
8184 function sgipi(it1, it2, it3)
8185 implicit real *8(a-h, o-z)
8186 common /rms/rms(3, 50), s1, s2, s3
8187 common /herfun/hs1(60), hs2(60), hs3(60)
8188 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
8189 common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
8190 common /sgpth/mksgi, mksgp
8191 logical mksgi, mksgp
8196 if (.not. mksgi)
then 8201 it3kp1 = it3 - ik + 1
8203 sgi3(ik) = sgn*hs3(km1+1)*rms(3, it3k+1)
8206 jt3kj = 2*(it3-ik-jkm1)
8207 jt23kj = 2*(it3+it2-ik-jkm1)
8209 stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
8210 sgri(ik, jk) =
fpar(it3-ik, jkm1)/stoc
8211 sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+2)
8220 it3kp1 = it3 - ik + 1
8223 jt23kj = 2*(it3+it2-ik-jkm1)
8225 sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+2)
8237 function sgiii(it1, it2, it3)
8238 implicit real *8(a-h, o-z)
8239 common /rms/rms(3, 50), s1, s2, s3
8240 common /herfun/hs1(60), hs2(60), hs3(60)
8241 common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
8242 common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
8243 common /sgpth/mksgi, mksgp
8244 logical mksgi, mksgp
8249 if (.not. mksgi)
then 8254 it3kp1 = it3 - ik + 1
8256 sgi3(ik) = sgn*hs3(km1+1)*rms(3, it3k+1)
8259 jt3kj = 2*(it3-ik-jkm1)
8260 jt23kj = 2*(it3+it2-ik-jkm1)
8262 stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
8263 sgri(ik, jk) =
fpar(it3-ik, jkm1)/stoc
8264 sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+2)
8273 it3kp1 = it3 - ik + 1
8276 jt23kj = 2*(it3+it2-ik-jkm1)
8278 sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+2)
8297 function uppp(it1, it2, it3)
8298 implicit real *8(a-h, o-z)
8299 common /rms/rms(3, 50), s1, s2, s3
8300 common /gauss1/absg(40), wg(40), igaus
8301 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8302 common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8303 common /expmod/ragp(40, 100), ragm1(40, 40)
8304 common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8307 ind = 2*(it1+it2+it3) + 1
8311 cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
8314 arcc(i, j) = ragp(i, ind)*akpcc(i, j)
8315 u = u + arcc(i, j)*epsi1(i, j)
8327 function upip(it1, it2, it3)
8328 implicit real *8(a-h, o-z)
8329 common /rms/rms(3, 50), s1, s2, s3
8330 common /gauss1/absg(40), wg(40), igaus
8331 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8332 common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8333 common /expmod/ragp(40, 100), ragm1(40, 40)
8334 common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8337 ind = 2*(it1+it2+it3) + 2
8341 cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
8344 arcs(i, j) = ragp(i, ind)*akpcs(i, j)
8345 u = u + arcs(i, j)*epsi1(i, j)
8357 function uppi(it1, it2, it3)
8358 implicit real *8(a-h, o-z)
8359 common /rms/rms(3, 50), s1, s2, s3
8360 common /gauss1/absg(40), wg(40), igaus
8361 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8362 common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8363 common /expmod/ragp(40, 100), ragm1(40, 40)
8364 common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8367 ind = 2*(it1+it2+it3) + 2
8371 cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
8374 arsc(i, j) = ragp(i, ind)*akpsc(i, j)
8375 u = u + arsc(i, j)*epsi1(i, j)
8387 function upii(it1, it2, it3)
8388 implicit real *8(a-h, o-z)
8389 common /rms/rms(3, 50), s1, s2, s3
8390 common /gauss1/absg(40), wg(40), igaus
8391 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8392 common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8393 common /expmod/ragp(40, 100), ragm1(40, 40)
8394 common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8397 ind = 2*(it1+it2+it3+1) + 1
8401 cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
8404 arss(i, j) = ragp(i, ind)*akpss(i, j)
8405 u = u + arss(i, j)*epsi1(i, j)
8417 function uipp(it1, it2, it3)
8418 implicit real *8(a-h, o-z)
8419 common /rms/rms(3, 50), s1, s2, s3
8420 common /gauss1/absg(40), wg(40), igaus
8421 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8422 common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8423 common /expmod/ragp(40, 100), ragm1(40, 40)
8424 common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8427 ind = 2*(it1+it2+it3+1)
8431 cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
8434 arcc(i, j) = ragp(i, ind)*akpcc(i, j)
8435 u = u + arcc(i, j)*epsi1(i, j)
8446 function uiip(it1, it2, it3)
8447 implicit real *8(a-h, o-z)
8448 common /rms/rms(3, 50), s1, s2, s3
8449 common /gauss1/absg(40), wg(40), igaus
8450 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8451 common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8452 common /expmod/ragp(40, 100), ragm1(40, 40)
8453 common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8456 ind = 2*(it1+it2+it3+1) + 1
8460 cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
8463 arcs(i, j) = ragp(i, ind)*akpcs(i, j)
8464 u = u + arcs(i, j)*epsi1(i, j)
8475 function uipi(it1, it2, it3)
8476 implicit real *8(a-h, o-z)
8477 common /rms/rms(3, 50), s1, s2, s3
8478 common /gauss1/absg(40), wg(40), igaus
8479 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8480 common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8481 common /expmod/ragp(40, 100), ragm1(40, 40)
8482 common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8485 ind = 2*(it1+it2+it3+1) + 1
8489 cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
8492 arsc(i, j) = ragp(i, ind)*akpsc(i, j)
8493 u = u + arsc(i, j)*epsi1(i, j)
8505 function uiii(it1, it2, it3)
8506 implicit real *8(a-h, o-z)
8507 common /rms/rms(3, 50), s1, s2, s3
8508 common /gauss1/absg(40), wg(40), igaus
8509 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8510 common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8511 common /expmod/ragp(40, 100), ragm1(40, 40)
8512 common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8515 ind = 2*(it1+it2+it3+1) + 2
8519 cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
8522 arss(i, j) = ragp(i, ind)*akpss(i, j)
8523 u = u + arss(i, j)*epsi1(i, j)
8535 implicit real *8(a-h, o-z)
8536 common /rms/rms(3, 50), s1, s2, s3
8537 common /gauss1/absg(40), wg(40), igaus
8538 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8539 common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8540 common /expmod/ragp(40, 100), ragm1(40, 40)
8541 common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8547 u = u + arcc(i, j)*ragm1(i, k)*epsi2(i, j)
8559 implicit real *8(a-h, o-z)
8560 common /rms/rms(3, 50), s1, s2, s3
8561 common /gauss1/absg(40), wg(40), igaus
8562 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8563 common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8564 common /expmod/ragp(40, 100), ragm1(40, 40)
8565 common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8571 u = u + arcs(i, j)*ragm1(i, k)*epsi2(i, j)
8583 implicit real *8(a-h, o-z)
8584 common /rms/rms(3, 50), s1, s2, s3
8585 common /gauss1/absg(40), wg(40), igaus
8586 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8587 common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8588 common /expmod/ragp(40, 100), ragm1(40, 40)
8589 common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8595 u = u + arsc(i, j)*ragm1(i, k)*epsi2(i, j)
8607 implicit real *8(a-h, o-z)
8608 common /rms/rms(3, 50), s1, s2, s3
8609 common /gauss1/absg(40), wg(40), igaus
8610 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8611 common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8612 common /expmod/ragp(40, 100), ragm1(40, 40)
8613 common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8619 u = u + arss(i, j)*ragm1(i, k)*epsi2(i, j)
8631 implicit real *8(a-h, o-z)
8632 common /rms/rms(3, 50), s1, s2, s3
8633 common /gauss1/absg(40), wg(40), igaus
8634 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8635 common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8636 common /expmod/ragp(40, 100), ragm1(40, 40)
8637 common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8643 u = u + arcc(i, j)*ragm1(i, k)*epsi2(i, j)
8655 implicit real *8(a-h, o-z)
8656 common /rms/rms(3, 50), s1, s2, s3
8657 common /gauss1/absg(40), wg(40), igaus
8658 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8659 common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8660 common /expmod/ragp(40, 100), ragm1(40, 40)
8661 common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8667 u = u + arcs(i, j)*ragm1(i, k)*epsi2(i, j)
8679 implicit real *8(a-h, o-z)
8680 common /rms/rms(3, 50), s1, s2, s3
8681 common /gauss1/absg(40), wg(40), igaus
8682 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8683 common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8684 common /expmod/ragp(40, 100), ragm1(40, 40)
8685 common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8691 u = u + arsc(i, j)*ragm1(i, k)*epsi2(i, j)
8703 implicit real *8(a-h, o-z)
8704 common /rms/rms(3, 50), s1, s2, s3
8705 common /gauss1/absg(40), wg(40), igaus
8706 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8707 common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8708 common /expmod/ragp(40, 100), ragm1(40, 40)
8709 common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8715 u = u + arss(i, j)*ragm1(i, k)*epsi2(i, j)
8727 implicit real *8(a-h, o-z)
8728 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
8729 common /faisc/f(10, iptsz), imax, ngood
8730 common /consta/vl, pi, xmat, rpel, qst
8731 common /dyn/tref, vref
8732 common /sc3/beamc, scdist, sce10, cplm, ectt, apl, ichaes, iscsp
8733 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
8734 common /part/xc(iptsz), yc(iptsz), zc(iptsz)
8735 common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
8737 common /vpintim/gcg, bcg
8738 common /coef/a(30, 30, 30), xrmsz, yrmsz, zrmsz
8742 write (16, *)
' space charge with HERSC call number: ', nuelm
8749 trmoy = trmoy + f(6, i)
8754 trmoy = trmoy/float(ngood)
8755 wcg = wcg/float(ngood)
8757 bcg = sqrt(1.-1./(gcg*gcg))
8758 xcg = xcg/float(ngood)
8759 ycg = ycg/float(ngood)
8775 bnp = sqrt(1.-1./(gnp*gnp))
8776 zc(np) = (trmoy-f(6,np))*bnp*vl/100.
8780 xc(np) = (f(2,np)-xcg)/100.
8781 xb2z = xb2z + zc(np)*zc(np)
8782 xb2x = xb2x + xc(np)*xc(np)
8783 xbxz = xbxz + zc(np)*xc(np)
8786 xb2z = xb2z/float(imaxx)
8787 xb2x = xb2x/float(imaxx)
8788 xbxz = xbxz/float(imaxx)
8789 apl = atan(-2.*xbxz/(xb2x-xb2z))/2.
8791 write (16, *)
'*slope of the bunch in plane(Oz,Ox):', apl,
' radian' 8800 bnp = sqrt(1.-1./(gnp*gnp))
8801 znp = (trmoy-f(6,np))*bnp*vl
8806 zc(np) = znp*cos(apl) + xnp*sin(apl)
8807 xnp = xnp*cos(apl) - znp*sin(apl)
8809 f3 = f(3, np)*1.e-03
8810 f5 = f(5, np)*1.e-03
8812 xc(np) = (xnp+zc(np)*f3)/100.
8813 yc(np) = (f(4,np)+zc(np)*f5)/100.
8814 zc(np) = zc(np)/100.
8816 xbar = xbar + xc(np)
8817 ybar = ybar + yc(np)
8818 zbar = zbar + zc(np)
8825 xc(np) = xc(np) - xbar
8826 yc(np) = yc(np) - ybar
8827 zc(np) = zc(np) - zbar
8836 implicit real *8(a-h, o-z)
8837 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
8838 common /faisc/f(10, iptsz), imax, ngood
8839 common /consta/vl, pi, xmat, rpel, qst
8840 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
8841 common /hcgrms/xcdg, ycdg, zcdg, ect, eps
8842 common /ind/lmax, mmax, nmax
8843 common /indttal/lmnt
8844 common /randu/ck(15), kmax
8845 common /coef/a(30, 30, 30), xrmsz, yrmsz, zrmsz
8846 common /part/xc(iptsz), yc(iptsz), zc(iptsz)
8848 common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
8851 common /facrms/fxrms, fyrms, fzrms
8853 common /factor/fpir(40, 40), fect(30)
8854 dimension hx(30), hy(30), hz(30), tran(1)
8876 xcg = xcg/float(ngood)
8877 ycg = ycg/float(ngood)
8878 zcg = zcg/float(ngood)
8887 xsqsum = xsqsum + xcj*xcj
8888 ysqsum = ysqsum + ycj*ycj
8889 zsqsum = zsqsum + zcj*zcj
8891 xrmsz = xsqsum/float(ngood)
8892 yrmsz = ysqsum/float(ngood)
8893 zrmsz = zsqsum/float(ngood)
8897 write (16, *)
'*RMS of the bunch (m): ', xrmsz, yrmsz, zrmsz
8925 xc(j) = (xcp(j)-xcg)/xrmsz
8926 yc(j) = (ycp(j)-ycg)/yrmsz
8927 zc(j) = (zcp(j)-zcg)/zrmsz
8928 if ((abs(xc(j))<fxrms) .and. (abs(yc(j))<fyrms) .and. (abs(zc(j))<fzrms))
then 8935 if (kn>2) hz(kn) = zc(j)*hz(kn-1) - float(kn-2)*hz(kn-2)
8937 if (km>2) hy(km) = yc(j)*hy(km-1) - float(km-2)*hy(km-2)
8939 if (kl>2) hx(kl) = xc(j)*hx(kl-1) - float(kl-2)*hx(kl-2)
8940 xherm = hx(kl)*hy(km)*hz(kn)/(fect(kl)*fect(km)*fect(kn))
8941 a(kl, km, kn) = a(kl, km, kn) + xherm/pwtpi*ach
8947 rate = float(ngood)/float(irct)
8952 a(kl, km, kn) = a(kl, km, kn)*rate
8959 rdcfc = rdcf*float(imax)/float(ngood)
8960 if (rdcfc>1.) rdcfc = 1.
8967 call rlux(tran, len)
8968 if (tran(1)<=rdcfc)
then 8969 xc(j) = (xcp(j)-xcg)/xrmsz
8970 yc(j) = (ycp(j)-ycg)/yrmsz
8971 zc(j) = (zcp(j)-zcg)/zrmsz
8972 if ((abs(xc(j))<fxrms) .and. (abs(yc(j))<=fyrms) .and. (abs(zc(j))<fzrms))
then 8979 if (kn>2) hz(kn) = zc(j)*hz(kn-1) - float(kn-2)*hz(kn-2)
8981 if (km>2) hy(km) = yc(j)*hy(km-1) - float(km-2)*hy(km-2)
8983 if (kl>2) hx(kl) = xc(j)*hx(kl-1) - float(kl-2)*hx(kl-2)
8984 xherm = hx(kl)*hy(km)*hz(kn)/(fect(kl)*fect(km)*fect(kn))
8985 a(kl, km, kn) = a(kl, km, kn) + xherm/pwtpi*ach
8992 rate = float(ngood)/float(irct)
8993 write (16, *)
' particles kept in Almn: ', irct
8997 a(kl, km, kn) = a(kl, km, kn)*rate
9010 cesl = (1.-float(kl-1)/float(lsup))
9011 cesm = (1.-float(km-1)/float(msup))
9012 cesn = (1.-float(kn-1)/float(nsup))
9013 ces = cesl*cesm*cesn
9015 a(kl, km, kn) = a(kl, km, kn)*ces
9022 fond = abs(a(1,1,1))
9027 ipar = n - 2*int(n/2)
9028 if (ipar==0) zz = 0.
9033 if (n>5 .and. n<=11) zz = 0.50
9034 if (n>11) zz = 0.375
9038 ipar = m - 2*int(m/2)
9039 if (ipar==0) yy = 0.
9044 if (m>5 .and. m<=11) yy = 0.50
9045 if (m>11) yy = 0.375
9049 ipar = l - 2*int(l/2)
9050 if (ipar==0) xx = 0.
9055 if (l>5 .and. l<=11) xx = 0.50
9056 if (l>11) xx = 0.375
9060 ab = abs(a(kl,km,kn)*xherm)/fond
9069 rpeps = float(iret)/float(itot)
9070 write (16, *)
'*significant terms in Hermite series expansion: ', iret,
' total of terms :', itot
9072 write (16, *)
' problem in space charge : rpeps gt .3 ', rpeps
9083 if (a(kl,km,kn)/=0.)
then 9084 itm = kl + km + kn - 3
9085 if (itm>=lmnt) lmnt = itm
9086 if (lsup<=kl) lsup = kl
9087 if (msup<=km) msup = km
9088 if (nsup<=kn) nsup = kn
9093 lmnt = lmnt + kmax + 4 + 3
9094 write (16, *)
' maximum of n m l for the significants terms ', nsup - 1, msup - 1, lsup - 1
9095 write (16, *)
' maximun of (t) for the significants terms ', lmnt
9110 end subroutine hcoef 9115 subroutine hersc(ini)
9116 implicit real *8(a-h, o-z)
9117 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
9118 common /faisc/f(10, iptsz), imax, ngood
9119 common /consta/vl, pi, xmat, rpel, qst
9120 common /sc3/beamc, scdist, sce10, cplm, ectt, apl, ichaes, iscsp
9121 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
9122 common /cdek/dwp(iptsz)
9123 common /part/xc(iptsz), yc(iptsz), zc(iptsz)
9124 common /coef/a(30, 30, 30), xrmsz, yrmsz, zrmsz
9125 common /hcgrms/xcdg, ycdg, zcdg, ect, eps
9126 common /ind/lmax, mmax, nmax
9127 common /indin/lmaxi, mmaxi, nmaxxi
9128 common /indttal/lmnt
9129 common /rms/rms(3, 50), s1, s2, s3
9130 common /randu/ck(15), kmax
9131 common /circu/co(40, 50), sn(40, 50), blam(40, 100)
9132 common /gauss1/absg(40), wg(40), igaus
9133 common /field/ex, ey, ez
9134 common /expmod/ragp(40, 100), ragm1(40, 40)
9135 common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
9136 common /facrms/fxrms, fyrms, fzrms
9137 common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
9138 common /beamsa/fs(7, iptsz)
9142 common /compt/nrres, nrtre, nrbunc, nrdbun
9145 common /tapes/in, ifile, meta
9147 common /locher/rx, ry, rz, nx, ny, nz
9148 logical ichaes, iesp
9149 dimension exk(15, 15, 30), eyk(15, 15, 30), ezk(15, 15, 30)
9150 data lbmax, mbmax, nbmax/23, 23, 23/
9168 read (in, *) lmaxi, mmaxi, nmaxxi
9169 write (16, *)
'upper limits ', lmaxi, mmaxi, nmaxxi
9170 read (in, *) fxrms, fyrms, fzrms
9171 write (16, *)
' rms factors', fxrms, fyrms, fzrms
9173 write (16, *)
' select the Hermite cefficients with: ', eps
9188 if (rdcf>1.) rdcf = 1.
9190 if (ngood>15000)
then 9191 rdcf = 15000./float(ngood)
9196 call table(lbmax, mbmax, nbmax)
9223 if (a(ican,icam,ical)/=0.) icoa = icoa + 1
9234 delx = 2.*rx/float(nx)
9235 dely = 2.*ry/float(ny)
9236 delz = 2.*rz/float(nz)
9241 freq = fh*0.5e-06/pi
9242 epsilon = 8.854189586e-12
9244 const2 = 1.e-06/xmat
9252 qmpart = 1.0e-9*beamc/(float(imax)*freq)
9254 write (16, *)
' all the particles are lost ' 9257 qmpart = qmpart*ratei
9258 vrms = xrmsz*yrmsz*zrmsz
9259 cmacro = qmpart/(epsilon*vrms)
9264 wcg = wcg/float(ngood)
9267 bcg = sqrt(1.-1./(gcg*gcg))
9270 cmacro = cmacro/gmoy
9272 cmacrxy = cmacro/(bmoy*bmoy*gmoy*gmoy)
9285 ax = pwtpi*rms(3, 2)
9286 ay = pwtpi*rms(2, 2)
9287 az = pwtpi*rms(1, 2)
9296 ax = pwtpi*rms(1, 2)
9297 ay = pwtpi*rms(3, 2)
9298 az = pwtpi*rms(2, 2)
9307 ax = pwtpi*rms(2, 2)
9308 ay = pwtpi*rms(1, 2)
9309 az = pwtpi*rms(3, 2)
9326 if (a(jl,jm,jn)/=0.)
then 9327 call fielde(jl1, jm1, jn1, isucc)
9329 exk(i, j, k) = a(jl, jm, jn)/ax*ex + exk(i, j, k)
9330 eyk(i, j, k) = a(jl, jm, jn)/ay*ey + eyk(i, j, k)
9331 ezk(i, j, k) = a(jl, jm, jn)/az*ez + ezk(i, j, k)
9368 i = int((u+rx)/delx) + 1
9369 j = int((v+ry)/dely) + 1
9370 k = int((w+rz)/delz) + 1
9372 if (i>0 .and. i<=nx .and. j>0 .and. j<=ny .and. k>0 .and. k<=nz)
then 9373 xnd1 = -rx + float(i-1)*delx
9374 ynd1 = -ry + float(j-1)*dely
9375 znd1 = -rz + float(k-1)*delz
9386 ex12 = (exk(i+1,j,k)-exk(i,j,k))*delux + exk(i, j, k)
9388 ex43 = (exk(i+1,j,k+1)-exk(i,j,k+1))*delux + exk(i, j, k+1)
9390 exp1 = (ex43-ex12)*delwz + ex12
9394 ex56 = (exk(i+1,j+1,k)-exk(i,j+1,k))*delux + exk(i, j+1, k)
9396 ex87 = (exk(i+1,j+1,k+1)-exk(i,j+1,k+1))*delux + exk(i, j+1, k+1)
9398 exp3 = (ex87-ex56)*delwz + ex56
9400 exp13 = (exp3-exp1)*delvy + exp1
9406 exp2 = (ex56-ex12)*delvy + ex12
9410 ex43 = (exk(i+1,j,k+1)-exk(i,j,k+1))*delux + exk(i, j, k+1)
9412 ex87 = (exk(i+1,j+1,k+1)-exk(i,j+1,k+1))*delux + exk(i, j+1, k+1)
9414 exp5 = (ex87-ex43)*delvy + ex43
9416 exp25 = (exp5-exp2)*delwz + exp2
9418 ext = (exp13+exp25)/2.
9423 ey15 = (eyk(i,j+1,k)-eyk(i,j,k))*delvy + eyk(i, j, k)
9425 ey26 = (eyk(i+1,j+1,k)-eyk(i+1,j,k))*delvy + eyk(i+1, j, k)
9427 eyp2 = (ey26-ey15)*delu/delx + ey15
9431 ey48 = (eyk(i,j+1,k+1)-eyk(i,j,k+1))*delvy + eyk(i, j, k+1)
9433 ey37 = (eyk(i+1,j+1,k+1)-eyk(i+1,j,k+1))*delvy + eyk(i+1, j, k+1)
9435 eyp5 = (ey37-ey48)*delux + ey48
9437 eyp25 = (eyp5-eyp2)*delwz + eyp2
9443 eyp6 = (ey48-ey15)*delwz + ey15
9449 eyp4 = (ey37-ey26)*delwz + ey26
9451 eyp46 = (eyp4-eyp6)*delux + eyp6
9453 eyt = (eyp25+eyp46)/2.
9458 ez14 = (ezk(i,j,k+1)-ezk(i,j,k))*delwz + ezk(i, j, k)
9460 ez23 = (ezk(i+1,j,k+1)-ezk(i+1,j,k))*delwz + ezk(i+1, j, k)
9462 ezp1 = (ez23-ez14)*delux + ez14
9466 ez58 = (ezk(i,j+1,k+1)-ezk(i,j+1,k))*delwz + ezk(i, j+1, k)
9468 ez67 = (ezk(i+1,j+1,k+1)-ezk(i+1,j+1,k))*delwz + ezk(i+1, j+1, k)
9470 ezp3 = (ez67-ez58)*delux + ez58
9472 ezp13 = (ezp3-ezp1)*delvy + ezp1
9476 ez14 = (ezk(i,j,k+1)-ezk(i,j,k))*delwz + ezk(i, j, k)
9478 ez58 = (ezk(i,j+1,k+1)-ezk(i,j+1,k))*delwz + ezk(i, j+1, k)
9480 ezp6 = (ez58-ez14)*delvy + ez14
9484 ez23 = (ezk(i+1,j,k+1)-ezk(i+1,j,k))*delwz + ezk(i+1, j, k)
9486 ez67 = (ezk(i+1,j+1,k+1)-ezk(i+1,j+1,k))*delwz + ezk(i+1, j+1, k)
9488 ezp4 = (ez67-ez23)*delvy + ez23
9490 ezp64 = (ezp4-ezp6)*delux + ezp6
9492 ezt = (ezp13+ezp64)/2.
9495 eztp = ezt*cos(apl) - ext*sin(apl)
9496 extp = ezt*sin(apl) + ext*cos(apl)
9500 bsc = sqrt(1.-1./(gsc*gsc))
9503 dxp = const2*ext*dz*cmacrxy*abs(f(9,ic))
9504 dyp = const2*eyt*dz*cmacrxy*abs(f(9,ic))
9505 dw = const3*ezt*dz*cmacro*abs(f(9,ic))
9509 if (.not. iesp)
then 9512 f(js, ic) = fs(js, ic)
9514 f(3, ic) = f(3, ic) + dxp*1000.
9515 f(5, ic) = f(5, ic) + dyp*1000.
9516 f(2, ic) = f(2, ic) - dz1*dxp*100.*xpsc
9517 f(4, ic) = f(4, ic) - dz1*dyp*100.*xpsc
9522 f(3, ic) = f(3, ic) + dxp*1000.
9523 f(5, ic) = f(5, ic) + dyp*1000.
9524 f(7, ic) = f(7, ic) + dw
9533 s3 = xc(ic)/rms(3, 2)
9534 s2 = yc(ic)/rms(2, 2)
9535 s1 = zc(ic)/rms(1, 2)
9536 ax = pwtpi*rms(3, 2)
9537 ay = pwtpi*rms(2, 2)
9538 az = pwtpi*rms(1, 2)
9544 s3 = yc(ic)/rms(3, 2)
9545 s2 = zc(ic)/rms(2, 2)
9546 s1 = xc(ic)/rms(1, 2)
9547 ax = pwtpi*rms(1, 2)
9548 ay = pwtpi*rms(3, 2)
9549 az = pwtpi*rms(2, 2)
9555 s3 = zc(ic)/rms(3, 2)
9556 s2 = xc(ic)/rms(2, 2)
9557 s1 = yc(ic)/rms(1, 2)
9558 ax = pwtpi*rms(2, 2)
9559 ay = pwtpi*rms(1, 2)
9560 az = pwtpi*rms(3, 2)
9581 if (a(jl,jm,jn)/=0.)
then 9584 call fielde(jl1, jm1, jn1, isucc)
9586 ext = a(jl, jm, jn)/ax*ex + ext
9587 eyt = a(jl, jm, jn)/ay*ey + eyt
9588 ezt = a(jl, jm, jn)/az*ez + ezt
9598 eztp = ezt*cos(apl) - ext*sin(apl)
9599 extp = ezt*sin(apl) + ext*cos(apl)
9603 bsc = sqrt(1.-1./(gsc*gsc))
9606 dxp = const2*ext*dz*cmacrxy*abs(f(9,ic))
9607 dyp = const2*eyt*dz*cmacrxy*abs(f(9,ic))
9608 dw = const3*ezt*dz*cmacro*abs(f(9,ic))
9609 if (.not. iesp)
then 9612 f(js, ic) = fs(js, ic)
9614 f(3, ic) = f(3, ic) + dxp*1000.
9615 f(5, ic) = f(5, ic) + dyp*1000.
9616 f(2, ic) = f(2, ic) - dz1*dxp*100.*xpsc
9617 f(4, ic) = f(4, ic) - dz1*dyp*100.*xpsc
9622 f(3, ic) = f(3, ic) + dxp*1000.
9623 f(5, ic) = f(5, ic) + dyp*1000.
9624 f(7, ic) = f(7, ic) + dw
9631 write (16, *)
' particles in the mesh:', insd,
' outside: ', iout
9636 end subroutine hersc 9645 subroutine xtypl1(gami, saphi, qsc, dcg)
9646 implicit real *8(a-h, o-z)
9647 common /consta/vl, pi, xmat, rpel, qst
9649 common /jacob/gaks, gaps
9650 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
9651 common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
9652 common /typl1/yh1k0, yh1k1, yp1k1, yp1k2, yh1k00, yh1k01, yp1k01, yp1k02, yh10, yh11, yp11, yp12
9653 common /typl2/yh2k0, yh2k1, yp2k1, yp2k2, yh2k00, yh2k01, yp2k01, yp2k02, yh20, yh21, yp21, yp22
9655 common /typi1/ye1k0, ye1k1, ye1k2, ye1kc0, ye1kc1, ye1kc2, ye10, ye11, ye12
9656 common /typi2/ye2k0, ye2k1, ye2k2, ye2kc0, ye2kc1, ye2kc2, ye20, ye21, ye22
9657 dimension h(17), t(17)
9658 data t/ -.990575473, -.950675522, -.880239154, -.781514004, -.657671159, -.512690537, -.351231763, -.178484181, &
9659 0., .178484181, .351231763, .512690537, .657671159, .781514004, .880239154, .950675522, .990575473/
9660 data h/.024148303, .055459529, .085036148, .111883847, .135136368, .154045761, .168004102, .176562705, .179446470, &
9661 .176562705, .168004102, .154045761, .135136368, .111883847, .085036148, .055459529, .024148303/
9719 beti = sqrt(1.-1./gam2)
9721 tilta2 = phslip/(2.*eqvl)
9722 cgam10 = ((gami*gami-1.)**1.5)/fh0
9723 phcrtk = (t1k*sk-s1k*tk)/(tk*tk+sk*sk)
9727 xcc = eqvl*(1.+t(i))/2.
9729 if (xcc1>dcg)
go to 200
9730 phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
9732 if (phslip/=0.)
then 9733 git = cgi*sqcttf*cos(phit0-pcrest)/phslip
9734 gis = sin(xcc*tilta2)
9736 git = cgi*sqcttf*cos(phit0-pcrest)
9740 bi = sqrt(1.-1./(gi*gi))
9742 phit0k = -dtilk*(1.-xcc/eqvl)/2.
9743 if (phslip/=0.)
then 9744 gic = cos(xcc*tilta2)
9745 gak1 = dtilk*cos(phit0-pcrest)*gis/(phslip*phslip)
9746 gak2 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)/phslip
9747 gak3 = dtilk*cos(phit0-pcrest)*xcc*gic/(2.*phslip*eqvl)
9748 gak = cgi*sqcttf*(-gak1-gak2+gak3)
9750 gak1 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)
9751 gak = -cgi*sqcttf*gak1
9753 if (i==17) gaks = gak
9755 xint = 1./(bi*bi*bi*gi*gi*gi)
9756 phit1 = phit0 + xcc*phslip/(2.*eqvl)
9757 phtz0 = (xcc/eqvl-.5)*dtilk
9758 ha0 = 2.*sqcttf*cos(phit1-pcrest)*xint
9759 hb0 = 2.*sqcttf*sin(phit1-pcrest)*xint
9762 yh10 = yh10 + h(i)*ha0
9763 yh20 = yh20 + h(i)*hb0
9769 yh11 = yh11 + h(i)*ha0*xcc1
9770 yh21 = yh21 + h(i)*hb0*xcc1
9772 ye11 = ye11 + h(i)*hb0*xcc
9773 ye21 = ye21 + h(i)*ha0*xcc
9775 ye12 = ye12 + h(i)*hb0*xcc*xcc
9776 ye22 = ye22 + h(i)*ha0*xcc*xcc
9778 dha01 = sqcttf*cos(phit1-pcrest)*gi/((gi*gi-1.)**2.5)
9779 dha02 = sqcttf*cos(phit1-pcrest)*gi*gak/((gi*gi-1.)**2.5)
9780 dha03 = sqcttf*sin(phit1-pcrest)/((gi*gi-1.)**1.5)
9783 yh1k00 = yh1k00 + h(i)*dha01*6.*cgam10
9784 yh1k0 = yh1k0 + h(i)*(-6.*dha02+2.*(phcrtk-phtz0)*dha03)
9790 yh1k01 = yh1k01 + h(i)*dha01*xcc1*6.*cgam10
9791 yh1k1 = yh1k1 + h(i)*xcc1*(-6.*dha02+2.*(phcrtk-phtz0)*dha03)
9793 ye2kc1 = ye2kc1 + h(i)*dha01*xcc*6.*cgam10
9794 ye2k1 = ye2k1 + h(i)*xcc*(-6.*dha02-2.*(phcrtk-phtz0)*dha03)
9796 ye2kc2 = ye2kc2 + h(i)*dha01*xcc*xcc*6.*cgam10
9797 ye2k2 = ye2k2 + h(i)*xcc*xcc*(-6.*dha02-2.*(phcrtk-phtz0)*dha03)
9799 dhb01 = sqcttf*sin(phit1-pcrest)*gi/((gi*gi-1.)**2.5)
9800 dhb02 = sqcttf*sin(phit1-pcrest)*gi*gak/((gi*gi-1.)**2.5)
9801 dhb03 = sqcttf*cos(phit1-pcrest)/((gi*gi-1.)**1.5)
9804 yh2k00 = yh2k00 + h(i)*dhb01*6.*cgam10
9805 yh2k0 = yh2k0 + h(i)*(-6.*dhb02-2.*(phcrtk-phtz0)*dhb03)
9811 yh2k01 = yh2k01 + h(i)*dhb01*xcc1*6.*cgam10
9812 yh2k1 = yh2k1 + h(i)*xcc1*(-6.*dhb02-2.*(phcrtk-phtz0)*dhb03)
9814 ye1kc1 = ye1kc1 + h(i)*dhb01*xcc*6.*cgam10
9815 ye1k1 = ye1k1 + h(i)*xcc*(-6.*dhb02-2.*(phcrtk-phtz0)*dhb03)
9817 ye1kc2 = ye1kc2 + h(i)*dhb01*xcc*xcc*6.*cgam10
9818 ye1k2 = ye1k2 + h(i)*xcc*xcc*(-6.*dhb02-2.*(phcrtk-phtz0)*dhb03)
9820 pa0 = 2.*sqcttf*cos(phit1-pcrest)*xint*xint
9821 pb0 = 2.*sqcttf*sin(phit1-pcrest)*xint*xint
9823 yp11 = yp11 + h(i)*pa0*xcc1
9824 yp21 = yp21 + h(i)*pb0*xcc1
9826 yp12 = yp12 + h(i)*pa0*xcc1*xcc1
9827 yp22 = yp22 + h(i)*pb0*xcc1*xcc1
9829 dpa01 = sqcttf*cos(phit1-pcrest)*gi/((gi*gi-1.)**4)
9830 dpa02 = sqcttf*cos(phit1-pcrest)*gi*gak/((gi*gi-1.)**4)
9831 dpa03 = sqcttf*sin(phit1-pcrest)/((gi*gi-1.)**3)
9833 yp1k01 = yp1k01 + h(i)*dpa01*12.*cgam10*xcc1
9834 yp1k1 = yp1k1 + h(i)*xcc1*(-12.*dpa02+2.*(phcrtk-phtz0)*dpa03)
9836 yp1k02 = yp1k02 + h(i)*dpa01*12.*cgam10*xcc1*xcc1
9837 yp1k2 = yp1k2 + h(i)*xcc1*xcc1*(-12.*dpa02+2.*(phcrtk-phtz0)*dpa03)
9839 dpb01 = sqcttf*sin(phit1-pcrest)*gi/((gi*gi-1.)**4)
9840 dpb02 = sqcttf*sin(phit1-pcrest)*gi*gak/((gi*gi-1.)**4)
9842 dpb03 = sqcttf*cos(phit1-pcrest)/((gi*gi-1.)**3)
9844 yp2k01 = yp2k01 + h(i)*dpb01*12.*cgam10*xcc1
9845 yp2k1 = yp2k1 + h(i)*xcc1*(-12.*dpb02-2.*(phcrtk-phtz0)*dpb03)
9847 yp2k02 = yp2k02 + h(i)*dpb01*12.*cgam10*xcc1*xcc1
9848 yp2k2 = yp2k2 + h(i)*xcc1*xcc1*(-12.*dpb02-2.*(phcrtk-phtz0)*dpb03)
9853 yh1k00 = yh1k00/2.*eqvl
9854 yh1k01 = yh1k01/2.*eqvl
9855 yh1k0 = yh1k0/2.*eqvl
9856 yh1k1 = yh1k1/2.*eqvl
9857 yp1k1 = yp1k1/2.*eqvl
9858 yp1k2 = yp1k2/2.*eqvl
9859 yp1k01 = yp1k01/2.*eqvl
9860 yp1k02 = yp1k02/2.*eqvl
9866 ye1k0 = ye1k0/2.*eqvl
9867 ye1kc0 = ye1kc0/2.*eqvl
9868 ye1k1 = ye1k1/2.*eqvl
9869 ye1kc1 = ye1kc1/2.*eqvl
9870 ye1k2 = ye1k2/2.*eqvl
9871 ye1kc2 = ye1kc2/2.*eqvl
9877 yh2k00 = yh2k00/2.*eqvl
9878 yh2k01 = yh2k01/2.*eqvl
9879 yh2k0 = yh2k0/2.*eqvl
9880 yh2k1 = yh2k1/2.*eqvl
9881 yp2k1 = yp2k1/2.*eqvl
9882 yp2k2 = yp2k2/2.*eqvl
9883 yp2k01 = yp2k01/2.*eqvl
9884 yp2k02 = yp2k02/2.*eqvl
9890 ye2k0 = ye2k0/2.*eqvl
9891 ye2kc0 = ye2kc0/2.*eqvl
9892 ye2k1 = ye2k1/2.*eqvl
9893 ye2kc1 = ye2kc1/2.*eqvl
9894 ye2k2 = ye2k2/2.*eqvl
9895 ye2kc2 = ye2kc2/2.*eqvl
9908 implicit real *8(a-h, o-z)
9909 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
9910 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
9911 common /fene/wdisp, wphas, wx, wy, rlim, ifw
9912 common /faisc/f(10, iptsz), imax, ngood
9914 common /consta/vl, pi, xmat, rpel, qst
9915 common /tapes/in, ifile, meta
9916 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
9918 common /etchas/fractx, fracty, fractl
9919 common /etcom/cog(8), exten(17), fd(iptsz)
9920 common /pool/zl(iptsz), ipin(iptsz)
9922 if (fractl>=1.)
return 9928 nl = int(float(ngood)*fractl)
9937 tx2 = tx2 + f(6, i)*f(6, i)
9938 txp2 = txp2 + fd(i)*fd(i)
9939 txxp = txxp + f(6, i)*fd(i)
9941 tx2 = tx2/float(ngood)
9942 txp2 = txp2/float(ngood)
9943 txxp = txxp/float(ngood)
9944 delxxp = tx2*txp2 - txxp*txxp
9948 if (fd(i)/=0.) theta = atan(f(6,i)/fd(i))
9949 rpart = f(6, i)*f(6, i) + fd(i)*fd(i)
9950 cos2 = cos(theta)*cos(theta)
9951 sin2 = sin(theta)*sin(theta)
9952 denom = tx2*cos2 + txp2*sin2 - 2.*txxp*cos(theta)*sin(theta)
9953 relpse = 2.5*delxxp/denom
9954 if (fractl>=.97)
then 9955 relpse = 3.5*delxxp/denom
9957 if (fractl>=.95) relpse = 3.*delxxp/denom
9959 if (rpart<=relpse)
then 9964 write (16, *)
' CHASEL:', fractl,
' % over: ', ngood - ikept,
' particles' 9966 if (ipin(j)==1)
then 9968 if (imaxf<=nl)
go to 9990
9976 if (ichas(i)==1)
then 9979 tx2 = tx2 + f(6, i)*f(6, i)
9980 txp2 = txp2 + fd(i)*fd(i)
9981 txxp = txxp + f(6, i)*fd(i)
9985 tx = tx/float(imaxx)
9986 txp = txp/float(imaxx)
9987 tx2 = tx2/float(imaxx)
9988 txp2 = txp2/float(imaxx)
9989 txxp = txxp/float(imaxx)
9994 zzl = txp2 - txp*txp
9996 if (inz==1)
go to 8880
9997 flcrit = 2.*fl2rms*log(2.*imaxx)
9998 if (zlma<flcrit)
go to 7770
9999 8880 emil = sqrt(xxl*zzl-xzl*xzl)
10005 bl = sqrt(xxl/emil)
10011 7770 fl2rms = (1.+al*al)*xxl/bl + 2.*al*xzl + bl*zzl
10015 if (ichas(i)==1)
then 10016 psx = f(6, i) - tlx0
10018 zl(i) = psx*psx*cl*cl + (psx*al/bl+psz*bl)**2
10019 if (zlma<zl(i))
then 10027 if (zlma==0.) zlma = 1.e10
10029 if (ichas(i)==1 .and. zl(i)<zlma)
then 10046 implicit real *8(a-h, o-z)
10047 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
10048 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
10049 common /fene/wdisp, wphas, wx, wy, rlim, ifw
10050 common /faisc/f(10, iptsz), imax, ngood
10051 common /qmoyen/qmoy
10052 common /consta/vl, pi, xmat, rpel, qst
10053 common /tapes/in, ifile, meta
10054 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
10056 common /etchas/fractx, fracty, fractl
10057 common /pool/zl(iptsz), ipin(iptsz)
10059 if (fractx>=1.)
return 10065 nl = int(float(ngood)*fractx)
10074 f2 = f(2, i)*1.e-02
10075 f3 = f(3, i)*1.e-03
10077 txp2 = txp2 + f3*f3
10078 txxp = txxp + f2*f3
10080 tx2 = tx2/float(ngood)
10081 txp2 = txp2/float(ngood)
10082 txxp = txxp/float(ngood)
10083 delxxp = tx2*txp2 - txxp*txxp
10087 f2 = f(2, i)*1.e-02
10088 f3 = f(3, i)*1.e-03
10089 if (f3/=0.) theta = atan(f2/f3)
10090 rpart = f2*f2 + f3*f3
10091 cos2 = cos(theta)*cos(theta)
10092 sin2 = sin(theta)*sin(theta)
10093 denom = tx2*cos2 + txp2*sin2 - 2.*txxp*cos(theta)*sin(theta)
10094 relpse = 2.5*delxxp/denom
10095 if (fractx>=.97)
then 10096 relpse = 3.5*delxxp/denom
10098 if (fractx>=.95) relpse = 3.*delxxp/denom
10100 if (rpart<=relpse)
then 10105 write (16, *)
' CHASEX:', fractx,
' % over: ', ngood - ikept,
' particles' 10107 if (ipin(j)==1)
then 10109 if (imaxf<=nl)
go to 9990
10117 if (ichas(i)==1)
then 10119 txp = f(3, i) + txp
10120 tx2 = tx2 + f(2, i)*f(2, i)
10121 txp2 = txp2 + f(3, i)*f(3, i)
10122 txxp = txxp + f(2, i)*f(3, i)
10126 tx = tx/float(imaxx)
10127 txp = txp/float(imaxx)
10128 tx2 = tx2/float(imaxx)
10129 txp2 = txp2/float(imaxx)
10130 txxp = txxp/float(imaxx)
10135 zzl = txp2 - txp*txp
10136 xzl = txxp - tx*txp
10137 if (inz==1)
go to 8880
10138 flcrit = 2.*fl2rms*log(2.*imaxx)
10139 if (zlma<flcrit)
go to 7770
10140 8880 emil = sqrt(xxl*zzl-xzl*xzl)
10146 bl = sqrt(xxl/emil)
10152 7770 fl2rms = (1.+al*al)*xxl/bl + 2.*al*xzl + bl*zzl
10156 if (ichas(i)==1)
then 10157 psx = f(2, i) - tlx0
10158 psz = f(3, i) - tlz0
10159 zl(i) = psx*psx*cl*cl + (psx*al/bl+psz*bl)**2
10160 if (zlma<zl(i))
then 10168 if (zlma==0.) zlma = 1.e10
10170 if (ichas(i)==1 .and. zl(i)<zlma)
then 10187 implicit real *8(a-h, o-z)
10188 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
10189 common /tapes/in, ifile, meta
10190 common /etchas/fractx, fracty, fractl
10191 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
10194 read (in, *) fractx, fracty, fractl
10195 write (16, 1) fractx*100., fracty*100., fractl*100.
10196 1
format (
' ARE KEPT IN THE BUNCH ', /,
' (x,xp) : ', f7.3,
' %', /,
' (y,yp) : ', f7.3,
' % ', &
10197 /,
' (w,phase):', f7.3,
' %')
10200 if (fractx<1.) chasit = .true.
10201 if (fracty<1.) chasit = .true.
10202 if (fractl<1.) chasit = .true.
10204 end subroutine chase 10211 implicit real *8(a-h, o-z)
10212 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
10213 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
10214 common /fene/wdisp, wphas, wx, wy, rlim, ifw
10215 common /faisc/f(10, iptsz), imax, ngood
10216 common /qmoyen/qmoy
10217 common /consta/vl, pi, xmat, rpel, qst
10218 common /tapes/in, ifile, meta
10219 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
10221 common /etchas/fractx, fracty, fractl
10222 common /pool/zl(iptsz), ipin(iptsz)
10224 if (fracty>=1.)
return 10235 f4 = f(4, i)*1.e-02
10236 f5 = f(5, i)*1.e-03
10238 typ2 = typ2 + f5*f5
10239 tyyp = tyyp + f4*f5
10241 ty2 = ty2/float(ngood)
10242 typ2 = typ2/float(ngood)
10243 tyyp = tyyp/float(ngood)
10244 delyyp = ty2*typ2 - tyyp*tyyp
10247 f4 = f(4, i)*1.e-02
10248 f5 = f(5, i)*1.e-03
10250 if (f5/=0.) theta = atan(f4/f5)
10251 rpart = f4*f4 + f5*f5
10252 cos2 = cos(theta)*cos(theta)
10253 sin2 = sin(theta)*sin(theta)
10254 denom = ty2*cos2 + typ2*sin2 - 2.*tyyp*cos(theta)*sin(theta)
10255 relpse = 2.5*delyyp/denom
10256 if (fracty>=.97)
then 10257 relpse = 3.5*delyyp/denom
10259 if (fracty>=.95) relpse = 3.*delyyp/denom
10261 if (rpart<=relpse)
then 10266 write (16, *)
' CHASEY:', fracty,
' % over: ', ngood - ikept,
' particles' 10268 nl = int(float(ngood)*fracty)
10271 if (ipin(j)==1)
then 10273 if (imaxf<=nl)
go to 9990
10281 if (ichas(i)==1)
then 10283 typ = f(5, i) + typ
10284 ty2 = ty2 + f(4, i)*f(4, i)
10285 typ2 = typ2 + f(5, i)*f(5, i)
10286 tyyp = tyyp + f(4, i)*f(5, i)
10290 ty = ty/float(imaxx)
10291 typ = typ/float(imaxx)
10292 ty2 = ty2/float(imaxx)
10293 typ2 = typ2/float(imaxx)
10294 tyyp = tyyp/float(imaxx)
10299 zzl = typ2 - typ*typ
10300 xzl = tyyp - ty*typ
10301 if (inz==1)
go to 8880
10302 flcrit = 2.*fl2rms*log(2.*imaxx)
10303 if (zlma<flcrit)
go to 7770
10304 8880 emil = sqrt(xxl*zzl-xzl*xzl)
10310 bl = sqrt(xxl/emil)
10316 7770 fl2rms = (1.+al*al)*xxl/bl + 2.*al*xzl + bl*zzl
10320 if (ichas(i)==1)
then 10321 psx = f(4, i) - tlx0
10322 psz = f(5, i) - tlz0
10323 zl(i) = psx*psx*cl*cl + (psx*al/bl+psz*bl)**2
10324 if (zlma<zl(i))
then 10332 if (zlma==0.) zlma = 1.e10
10334 if (ichas(i)==1 .and. zl(i)<zlma)
then 10349 subroutine corre(n, nall)
10350 implicit real *8(a-h, o-z)
10351 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
10352 common /com4/cord(iptsz, 6)
10353 dimension a(6, 6), b(6, 6), c(6, 6), d(6), e(6), f(6), g(6)
10368 d(j) = d(j) + cord(i, j)
10374 cord(i, j) = cord(i, j) - d(j)
10380 a(j, k) = a(j, k) + cord(i, j)*cord(i, k)
10382 a(j, k) = a(j, k)/n
10392 h = h - a(i, k)*a(j, k)
10394 8
if (i==j)
go to 10
10395 a(i, j) = h/a(j, j)
10397 10 a(i, j) = sqrt(h)
10398 7 b(i, j) = a(i, j)
10410 if (jj==1)
go to 13
10412 s = s - b(k, i)*b(k, j)
10414 13 b(j, i) = (s-b(i,j)*e(i))/b(j, j)
10432 f(k) = f(k) + b(k, j)*cord(i, j)
10442 g(j) = g(j) + cord(i, j)
10448 cord(i, j) = cord(i, j) - g(j)
10454 c(j, k) = c(j, k) + cord(i, j)*cord(i, k)
10456 c(j, k) = c(j, k)/n
10460 end subroutine corre 10468 implicit real *8(a-h, o-z)
10469 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
10470 common /faisc/f(10, iptsz), imax, ngood
10471 common /qmoyen/qmoy
10472 common /part/xc(iptsz), yc(iptsz), zc(iptsz)
10473 common /consta/vl, pi, xmat, rpel, qst
10474 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
10475 common /azlist/icont, iprin
10481 grmoy = grmoy + f(7, i)/xmat
10482 trmoy = trmoy + f(6, i)
10483 xbax = xbax + f(2, i)
10485 trmoy = trmoy/float(ngood)
10486 grmoy = grmoy/float(ngood)
10487 brmoy = sqrt(1.-1./(grmoy*grmoy))
10488 xbax = xbax/float(ngood)
10497 gpai = f(7, np)/xmat
10498 bpai = sqrt(1.-1./(gpai*gpai))
10499 zc(np) = (trmoy-f(6,np))*bpai*vl/100.
10500 xc(np) = (f(2,np)-xbax)/100.
10501 xb2z = xb2z + zc(np)*zc(np)
10502 xb2x = xb2x + xc(np)*xc(np)
10503 xbxz = xbxz + zc(np)*xc(np)
10505 xb2z = xb2z/float(ngood)
10506 xb2x = xb2x/float(ngood)
10507 xbxz = xbxz/float(ngood)
10508 apl = atan(-2.*xbxz/(xb2x-xb2z))/2.
10509 write (16, *)
'slope of the bunch in plane(Oz,Ox):', apl,
' radian' 10512 gpai = f(7, np)/xmat
10513 bpai = sqrt(1.-1./(gpai*gpai))
10517 znp = (trmoy-f(6,np))*bpai*vl
10519 zc(np) = znp*cos(apl) + xnp*sin(apl)
10520 xnp = xnp*cos(apl) - znp*sin(apl)
10522 f3 = f(3, np)*1.e-03
10523 f5 = f(5, np)*1.e-03
10525 xc(np) = (xnp+zc(np)*f3)/100.
10526 yc(np) = (f(4,np)+zc(np)*f5)/100.
10527 zc(np) = zc(np)/100.
10534 xbar = xbar + xc(np)
10535 ybar = ybar + yc(np)
10536 zbar = zbar + zc(np)
10538 xbar = xbar/float(ngood)
10539 ybar = ybar/float(ngood)
10540 zbar = zbar/float(ngood)
10544 xc(np) = xc(np) - xbar
10545 yc(np) = yc(np) - ybar
10546 zc(np) = zc(np) - zbar
10556 implicit real *8(a-h, o-z)
10557 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
10558 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
10559 common /hermt/afxt(22), afyt(22), afzt(22)
10560 common /hermd/afxm(20), afym(20), afzm(20)
10561 common /hermr/afxr(20), afyr(20), afzr(20)
10562 common /sizt/xrms, yrms, zrms
10563 common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
10564 common /elcg/xcgd, ycgd, zcgd, xcgr, ycgr, zcgr
10565 common /intgrt/ex, ey, ez
10566 common /degherm/nmaz, nmazr, nmaxy
10567 common /cdek/dwp(iptsz)
10568 common /consta/vl, pi, xmat, rpel, qst
10569 common /faisc/f(10, iptsz), imax, ngood
10570 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
10571 common /npart/imaxr
10572 common /part/xc(iptsz), yc(iptsz), zc(iptsz)
10573 common /twcst/epsilon
10574 common /beamsa/fs(7, iptsz)
10577 common /cgrms/xsum, ysum, zsum
10578 common /compt/nrres, nrtre, nrbunc, nrdbun
10579 common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
10581 logical ichaes, iesp
10582 dimension afx(20), afy(20)
10584 if (beamc==0. .or. scdist==0.)
return 10587 wavel = 2.*pi*vl/fh
10588 xmass = xmat*1.78267581e-30
10596 write (16, *)
' all the particles are lost ' 10601 epsilon = 8.854189586e-12
10602 c1 = 1./(3.*pi*sqrt(5.))
10608 const2 = 1.e-06/xmat
10610 call sizrms(0, xrms, yrms, zrms, zz)
10615 call sizcor(ect, xrms, yrms, zrms, 0)
10637 if (zcp(i)>=zmat) zmat = zcp(i)
10638 if (zcp(i)<zmit) zmit = zcp(i)
10643 zmat = zmat + zmat*.50
10644 zmit = zmit + zmit*.50
10645 if (zmat>ect) zmat = ect
10646 if (abs(zmit)>ect) zmit = -ect
10661 xcoup = abs(xcp(j)/xrms)
10662 ycoup = abs(ycp(j)/yrms)
10663 zcoup = abs(zcp(j)/zrms)
10664 if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect)
then 10665 xc(j) = xcp(j)/xrmsc
10666 yc(j) = ycp(j)/yrmsc
10667 zc(j) = zcp(j)/zrmsc
10668 afxm(k) = afxm(k) +
herm(2*kap, xc(j))
10669 afym(k) = afym(k) +
herm(2*kap, yc(j))
10670 afzm(k) = afzm(k) +
herm(2*kap, zc(j))
10673 afxm(k) = afxm(k)/(
fact(2*kap)*sqrt(2.*pi))
10674 afym(k) = afym(k)/(
fact(2*kap)*sqrt(2.*pi))
10675 afzm(k) = afzm(k)/(
fact(2*kap)*sqrt(2.*pi))
10682 xcoup = abs(xcp(j)/xrms)
10683 ycoup = abs(ycp(j)/yrms)
10684 zcoup = abs(zcp(j)/zrms)
10685 if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect)
then 10686 zcdg = zcdg + zcp(j)
10690 zcdg = zcdg/float(imaxx)
10695 xcoup = abs(xcp(j)/xrms)
10696 ycoup = abs(ycp(j)/yrms)
10697 zcoup = abs(zcp(j)/zrms)
10698 if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect)
then 10699 zc(j) = zcp(j) - zcdg
10700 zsqsum = zsqsum + zc(j)*zc(j)
10701 zcub = zcub + zc(j)*zc(j)*zc(j)
10702 zcub1 = zcub1 + zc(j)
10705 zrmsz = zsqsum/float(imaxx)
10706 zrmsz = sqrt(zrmsz)
10708 zcub = zcub/(zrmsz*zrmsz*zrmsz) - 3.*zcub1/zrmsz
10709 zcub = zcub/(6.*sqrt(2.*pi))
10716 xcoup = abs(xcp(j)/xrms)
10717 ycoup = abs(ycp(j)/yrms)
10718 zcoup = abs(zcp(j)/zrms)
10719 if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect)
then 10720 zc(j) = zcp(j)/zrmsc
10721 xc(j) = xcp(j)/xrmsc
10722 yc(j) = ycp(j)/yrmsc
10723 afzt(k) = afzt(k) +
herm(kap, zc(j))
10724 afx(k) = afx(k) +
herm(kap, xc(j))
10725 afy(k) = afy(k) +
herm(kap, yc(j))
10728 afzt(k) = afzt(k)/(
fact(kap)*sqrt(2.*pi))
10729 afx(k) = afx(k)/(
fact(kap)*sqrt(2.*pi))
10730 afy(k) = afy(k)/(
fact(kap)*sqrt(2.*pi))
10747 eztp = ezt*cos(apl) - ext*sin(apl)
10748 extp = ezt*sin(apl) + ext*cos(apl)
10752 bsc = sqrt(1.-1./(gsc*gsc))
10754 dxp = const2*ext*dz/(bsc*bsc*gsc*gsc*gsc)*abs(f(9,i))
10755 dyp = const2*eyt*dz/(bsc*bsc*gsc*gsc*gsc)*abs(f(9,i))
10756 dw = const3*ezt*dz*abs(f(9,i))/gsc
10758 if (.not. iesp)
then 10761 f(js, i) = fs(js, i)
10763 f(3, i) = f(3, i) + dxp*1000.
10764 f(5, i) = f(5, i) + dyp*1000.
10765 f(2, i) = f(2, i) - dz1*dxp*100.*xpsc
10766 f(4, i) = f(4, i) - dz1*dyp*100.*xpsc
10769 f(3, i) = f(3, i) + dxp*1000.
10770 f(5, i) = f(5, i) + dyp*1000.
10771 f(7, i) = f(7, i) + dw
10782 implicit real *8(a-h, o-z)
10783 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
10784 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
10785 common /hermt/afxt(22), afyt(22), afzt(22)
10786 common /hermd/afxm(20), afym(20), afzm(20)
10787 common /hermr/afxr(20), afyr(20), afzr(20)
10788 common /hermrr/afxrr(20), afyrr(20), afzrr(20)
10789 common /sizr/xrms3, yrms3, zrms3, zcgr3
10790 common /sizt/xrms, yrms, zrms
10791 common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
10792 common /elcg/xcgd, ycgd, zcgd, xcgr, ycgr, zcgr
10793 common /intgrt/ex, ey, ez
10794 common /degherm/nmaz, nmazr, nmaxy
10795 common /cdek/dwp(iptsz)
10796 common /consta/vl, pi, xmat, rpel, qst
10797 common /faisc/f(10, iptsz), imax, ngood
10798 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
10799 common /npart/imaxr
10800 common /part/xc(iptsz), yc(iptsz), zc(iptsz)
10801 common /twcst/epsilon
10802 common /beamsa/fs(7, iptsz)
10805 common /champ/fxrms(10, 15), fyrms(10, 15), fzrms(10, 15), nchamp(10), nccham(10), nchpas, jcham, itye
10806 common /compt/nrres, nrtre, nrbunc, nrdbun
10808 logical ichaes, iesp
10811 common /chqua/icqd, nquad
10814 common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
10816 if (beamc==0. .or. scdist==0.)
return 10824 wavel = 2.*pi*vl/fh
10825 xmass = xmat*1.78267581e-30
10836 write (16, *)
' all the particles are lost ' 10839 write (16, *)
' call SCHERM N: ', iell
10842 epsilon = 8.854189586e-12
10843 c1 = 1./(3.*pi*sqrt(5.))
10847 const2 = 1.e-06/xmat
10850 call sizrms(0, xrms, yrms, zrms, zz)
10854 call sizcor(ect, xrms, yrms, zrms, 0)
10855 write (16, *)
' bunch RMS(m): ', xrms, yrms, zrms
10874 if (zcp(i)>=zmat) zmat = zcp(i)
10875 if (zcp(i)<zmit) zmit = zcp(i)
10880 zmat = zmat + zmat*.50
10881 zmit = zmit + zmit*.50
10883 if (zmat>ect) zmat = ect
10884 if (abs(zmit)>ect) zmat = -ect
10891 xcoup = abs(xcp(j)/xrms)
10892 ycoup = abs(ycp(j)/yrms)
10893 zcoup = abs(zcp(j)/zrms)
10894 if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect)
then 10895 xc(j) = xcp(j)/xrmsc
10896 yc(j) = ycp(j)/yrmsc
10897 afxt(k) = afxt(k) +
herm(2*kap, xc(j))
10898 afyt(k) = afyt(k) +
herm(2*kap, yc(j))
10901 afxt(k) = afxt(k)/(
fact(2*kap)*sqrt(2.*pi))
10902 afyt(k) = afyt(k)/(
fact(2*kap)*sqrt(2.*pi))
10909 xcoup = abs(xcp(j)/xrms)
10910 ycoup = abs(ycp(j)/yrms)
10911 zcoup = abs(zcp(j)/zrms)
10912 if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect)
then 10913 zc(j) = zcp(j)/zrms
10914 afzt(k) = afzt(k) +
herm(kap, zc(j))
10917 afzt(k) = afzt(k)/(
fact(kap)*sqrt(2.*pi))
10921 szbt =
snzt(zmit, zmat)
10926 call rchsom(zi, zf, nmaz)
10933 if (zcp(i)>=zcgd)
then 10941 imaxr = ngood - 2*imaxd
10944 pcent1 = float(2*imaxd)/float(ngood)
10945 pcent2 = float(imaxr)/float(ngood)
10946 if (icqd) nquad = nquad - 1
10948 write (16, *)
' one ellipsoid in z-direction ' 10953 if (25*imaxr<imaxf .or. imaxr<=30)
then 10954 pcent1 = float(2*imaxd)/float(ngood)
10955 pcent2 = float(imaxr)/float(ngood)
10957 if (icqd) nquad = nquad - 1
10959 write (16, *)
'one ellipsoid in z-direction ' 10962 if (12*imaxr<ngood)
write (16, *)
'one ellipsoid in z-direction ' 10963 if (imaxr<=40)
write (16, *)
' one ellipsoid in z-direction ' 10969 zrmss1 = sqrt(
vaprz(zsot,zmat))
10970 zrms1 = zrmss1*zrms
10975 szbd =
snzd(zsot, zmat)
10981 afxm(k) = afxt(k)*rsnz
10982 afym(k) = afyt(k)*rsnz
10983 afzm(k) =
prinz(zsot, zmat, k, zrmss1)
10984 afzm(k) = 2.*afzm(k)/(
fact(2*kap)*sqrt(2.*pi))
10996 if (xc(i)>=xmam) xmam = xc(i)
10997 if (yc(i)>=ymam) ymam = yc(i)
10998 if (zc(i)>=zmam) zmam = zc(i)
11000 if (abs(xmam)>=ect) xmam = ect
11001 if (abs(ymam)>=ect) ymam = ect
11002 if (abs(zmam)>=ect) zmam = ect
11007 if (xc(i)<xmim) xmim = xc(i)
11008 if (yc(i)<ymim) ymim = yc(i)
11009 if (zc(i)<zmim) zmim = zc(i)
11011 if (abs(xmim)>=ect) xmim = -ect
11012 if (abs(ymim)>=ect) ymim = -ect
11013 if (abs(zmim)>=ect) zmim = -ect
11017 if (xmam>=xymam) xymam = xmam
11018 if (zmam>=xymam) xymam = zmam
11019 if (xmim<xymim) xymim = xmim
11020 if (zmim<xymim) xymim = zmim
11022 if (abs(xymim)>=xymam)
then 11029 bb = 2.*zsot - zmat
11032 call rchsor(aa, bb, cc, dd, ee)
11035 zrms2 =
varia(bb, cc, dd, ee)
11036 zrms2 = sqrt(zrms2)
11038 sz2e =
codsy(bb, cc, dd, ee, 1)
11039 afzr(1) = sz2e/sqrt(2.*pi)
11040 stm12 = abs(afzt(1)-afzm(1)-afzr(1))
11046 afxr(k) = afxt(k)*rs2e
11047 afyr(k) = afyt(k)*rs2e
11048 afzr(k) =
codsy(bb, cc, dd, ee, k)
11049 afzr(k) = afzr(k)/(
fact(2*kap)*sqrt(2.*pi))
11052 if (stm12*10<=afzr(1)) inint = 2
11053 if (stm12*10>afzr(1))
then 11056 ee1 =
grz(aa, bb, cc, dd, ee)
11061 zrms3 =
variz(bb, cc, dd, ee, ee1)
11062 zrms3 = sqrt(zrms3)
11070 sz3e =
codif(bb, cc, dd, ee, ee1, 1)
11073 srtot = sz3e/sqrt(2.*pi) + afzr(1) + afzm(1)
11074 srtot = srtot - afzt(1)
11078 afxrr(k) = afxt(k)*rs3e
11079 afyrr(k) = afyt(k)*rs3e
11080 afzrr(k) =
codif(bb, cc, dd, ee, ee1, k)
11081 afzrr(k) = afzrr(k)/(
fact(2*kap)*sqrt(2.*pi))
11083 tzrr = afzrr(k) - srtot
11084 if (tzrr>=0. .and. abs(tzrr)>=(afzrr(k)/10.))
then 11085 afxrr(k) = afxrr(k) - srtot
11086 afyrr(k) = afyrr(k) - srtot
11087 afzrr(k) = afzrr(k) - srtot
11098 write (16, *)
' surface of the ellipsoids in % of the bunch:' 11100 pcent1 = afzm(1)/afzt(1)
11101 pcent2 = afzr(1)/afzt(1)
11102 write (16, 7777) iell, pcent1, pcent2
11105 pcent1 = afzm(1)/afzt(1)
11106 pcent2 = afzr(1)/afzt(1)
11107 pcent3 = afzrr(1)/afzt(1)
11108 write (16, 7778) iell, pcent1, pcent2, pcent3
11110 7777
format (2x, i4, 2x, f7.4, 2x, f7.4)
11111 7778
format (2x, i4, 2x, f7.4, 2x, f7.4, 2x, f7.4)
11142 eztp = ezt*cos(apl) - ext*sin(apl)
11143 extp = ezt*sin(apl) + ext*cos(apl)
11149 bsc = sqrt(1.-1./(gsc*gsc))
11150 dxp = const2*ext*dz/(bsc*bsc*gsc*gsc*gsc)*abs(f(9,i))
11151 dyp = const2*eyt*dz/(bsc*bsc*gsc*gsc*gsc)*abs(f(9,i))
11152 dw = const3*ezt*dz/gsc
11153 if (.not. iesp)
then 11156 f(js, i) = fs(js, i)
11158 f(3, i) = f(3, i) + dxp*1000.
11159 f(5, i) = f(5, i) + dyp*1000.
11160 f(2, i) = f(2, i) - dz1*dxp*100.*xpsc
11161 f(4, i) = f(4, i) - dz1*dyp*100.*xpsc
11166 f(3, i) = f(3, i) + dxp*1000.
11167 f(5, i) = f(5, i) + dyp*1000.
11168 f(7, i) = f(7, i) + dw
11194 implicit real *8(a-h, o-z)
11195 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
11196 common /consta/vl, pi, xmat, rpel, qst
11197 common /speda/dave, idave
11198 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
11199 common /dyn/tref, vref
11200 common /dyni/vrefi, trefi, fhinit, acpt
11201 common /faisc/f(10, iptsz), imax, ngood
11202 common /objet/fo(9, iptsz), imaxo
11203 common /histo/centre(6)
11204 common /qmoyen/qmoy
11206 common /mastrp/xma(2, 2), xmb(2, 2), xmc(2, 2)
11207 common /stis/suryth, surzph, enedep, ecogde, testca
11208 common /etcom/cog(8), exten(17), fd(iptsz)
11209 common /tapes/in, ifile, meta
11210 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
11211 common /tilt/tipha, tix, tiy, shifw, shifp
11212 common /newtlt/twissa(3), itwiss
11214 common /strip/atm, qs, atms, ths, qop, sqst(6), anp, nqst
11215 common /mcs/imcs, ncstat, cstat(20)
11216 common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
11217 common /trace3e/tracebi(6), traceei(3)
11218 character *128 trace3h, trace3t, tif
11222 read (in, *) uem, atm, qst
11223 if (ncstat==1) cstat(1) = qst
11225 read (in, *) enedep, tofini
11230 write (16, 101) uem, atm, xmat, qst
11231 101
format (
' **** unit mass: ', e12.5,
' MeV mass units: ', f5.1,
' rest mass: ', e12.5,
' MeV charge ', f4.1)
11232 write (16, 102) enedep, tofini
11233 102
format (
' **** energy: ', e12.5,
' MeV initial tof: ', e12.5,
' deg')
11234 tofini = tofini*pi/(180.*fh)
11235 gdep = enedep/xmat + 1.
11236 bdep = sqrt(1.-1./(gdep*gdep))
11238 tracebi(6) = tracebi(6)*sqrt(atm)
11239 write (tif, 901)(tracebi(i), i=1, 6)
11240 901
format (
' BEAMI(1)= ', 5(f12.6,1x), f12.4)
11242 trace3h(kt3h) = tif
11243 traceei(3) = traceei(3)/sqrt(atm)
11244 write (tif, 902)(traceei(i), i=1, 3)
11245 902
format (
' EMITI(1)= ', f12.6, 1x, f12.6, 1x, f12.4)
11247 trace3h(kt3h) = tif
11249 write (tif, 903) uem*atm/qst, fhinit/2./pi/1.e6
11250 903
format (
' ER= ', e16.7,
', Q=1 FREQ= ', e14.7)
11252 trace3h(kt3h) = tif
11253 write (tif, 7001) enedep/qst
11254 7001
format (
' W= ', f12.4)
11256 trace3h(kt3h) = tif
11269 if (itwiss/=1) fo(6, i) = fo(6, i) + tofini
11271 fo(7, i) = enedep + fo(1, i) + xmat
11272 if (fo(7,i)<xmat) fo(7, i) = xmat
11273 fo(1, i) = float(i)
11280 encog = encog + fo(7, i)
11281 gai = fo(7, i)/xmat
11282 bref = bref + sqrt(1.-1/(gai*gai))
11283 tref = tref + fo(6, i)
11285 encog = encog/float(ngood)
11286 bref = bref/float(ngood)
11288 tref = tref/float(ngood)
11298 gcog = 1./sqrt(1.-bref*bref)
11299 boro = 3.3356*xmat*bref*gcog/abs(qst)
11300 write (16, 3450) boro
11301 3450
format (
' **** momentum of c.o.g. (kG.cm): ', e12.5)
11302 if (itwiss==1)
then 11314 write (11, *) ngood, dum, fh/(2000000.*pi)
11316 f(2, i) = f(2, i) + centre(2)
11317 f(3, i) = f(3, i) + centre(3)
11318 f(4, i) = f(4, i) + centre(4)
11319 f(5, i) = f(5, i) + centre(5)
11320 f(6, i) = f(6, i) + centre(6)
11321 f(7, i) = f(7, i) + centre(1)
11322 etphas = fh*(f(6,i)-tref)
11323 etener = f(7, i) - xmat
11324 write (11, 777) f(2, i), f(3, i)/1000., f(4, i), f(5, i)/1000., etphas, etener
11326 777
format (6(f13.8,1x))
11339 end subroutine entre 11371 implicit real *8(a-h, o-z)
11372 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
11374 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
11375 common /com4/cord(iptsz, 6)
11376 common /faisc/f(10, iptsz), imax, ngood
11377 common /objet/fo(9, iptsz), imaxo
11378 common /qmoyen/qmoy
11379 common /histo/centre(6)
11380 common /consta/vl, pi, xmat, rpel, qst
11381 common /tapes/in, ifile, meta
11382 common /ranec1/dummy(6)
11383 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
11384 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
11385 common /newtlt/twissa(3), itwiss
11386 common /dyni/vrefi, trefi, fhinit, acpt
11387 common /speda/dave, idave
11391 common /fcont/ifcont
11393 common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
11394 common /trace3e/tracebi(6), traceei(3)
11395 character *128 trace3h, trace3t, tif
11396 logical iesp, chasit, dave
11400 read (in, *) loi, itwiss
11401 write (16, *)
' Generate particles based on law ', loi
11403 write (16, *) .gt.
' ERROR in GEBEAM: law 6 invalid ! ' 11406 read (in, *) fh, imax
11408 102
format (//, 30x,
' FREQUENCY : ', e12.5,
' Hz', //)
11413 read (in, *)(centre(j), j=2, 5), centre(1), centre(6)
11414 if (itwiss/=1)
then 11415 read (in, *) ymax, tmax, zmax, pmax, dmax, ttmax
11417 trace3h(kt3h) = .NE.
'ERROR: GEBEAM ITWISS1 not yet implemented' 11419 read (in, *) alphax, betax, emitx
11420 read (in, *) alphay, betay, emity
11421 read (in, *) alphaz, betaz, emitz
11422 gammax = (1.+alphax*alphax)/betax
11423 gammay = (1.+alphay*alphay)/betay
11424 ymax = 0.1*sqrt(emitx/gammax)
11425 tmax = sqrt(emitx*gammax)
11426 zmax = 0.1*sqrt(emity/gammay)
11427 pmax = sqrt(emity*gammay)
11428 twissa(1) = -alphax*ymax
11429 twissa(2) = -alphay*zmax
11431 gammaz = (1.+alphaz*alphaz)/betaz
11432 dmax = 0.001*sqrt(emitz*gammaz)
11433 ttmax = pi*sqrt(emitz/gammaz)/(fh*180.)
11434 twissa(3) = alphaz*sqrt(emitz/gammaz)
11445 tracebi(1) = alphax
11447 tracebi(3) = alphay
11449 tracebi(5) = alphaz
11456 cph = centre(6)*fh*180/pi
11457 write (16, 123)(centre(j), j=2, 5), centre(1), centre(6), cph
11458 123
format (
' *** Beam centre defined as:', /, 3x, 4x,
' Transverse direction :', /, 6x,
' HORZ PLANE X(CM) = ', &
11459 e12.5,
' XP(MRD) = ', e12.5, /, 6x,
' VERT PLANE Y(CM) = ', e12.5,
' YP(MRD) = ', e12.5, /, 4x, &
11460 ' LONGITUDINAL :', /, 5x,
' DELTA ENERGY(MeV) = ', e12.5,
' TIME(SEC) = ', e12.5, /, 41x,
' PHASE(DEG) = ', &
11462 ptmax = ttmax*fh*180./pi
11463 if (itwiss/=1)
then 11464 write (16, 99) ymax, tmax, zmax, pmax, dmax, ttmax, ptmax
11465 99
format (3x,
' *** Limits of the random distribution ', /, 4x,
' Transverse direction :', /, 6x, &
11466 ' HORZ PLANE X(CM) = ', e12.5,
' XP(MRD) = ', e12.5, /, 6x,
' VERT PLANE Y(CM) = ', e12.5, &
11467 ' YP(MRD) = ', e12.5, /, 4x,
' LONGITUDINAL :', /, 5x,
' DELTA ENERGY(MeV) = ', e12.5, &
11468 ' TIME(SEC) = ', e12.5, /, 41x,
' PHASE(DEG) = ', e12.5, //)
11472 write (16, *)
' Beam distribution based on Twiss parameters' 11473 write (16, 199) alphax, betax, emitx, alphay, betay, emity
11474 write (16, 399) ptmax, dmax
11475 399
format (4x,
' Continuous beam in the longitudinal direction :', /, 6x,
' half phase length (deg): ', e12.5, /, &
11476 6x,
' half energy width (MeV): ', e12.5)
11480 write (16, *)
' Beam distribution based on Twiss parameters' 11481 write (16, 199) alphax, betax, emitx, alphay, betay, emity
11482 199
format (4x,
' Transverse direction :', /, 6x,
' Horz plane: alpha: ', e12.5,
' beta(mm/mrad): ', e12.5, &
11483 ' emit(pi*mm*mrad): ', e12.5, /, 6x,
' Vert plane: alpha: ', e12.5,
' beta(mm/mrad): ', e12.5, &
11484 ' emit(pi*mm*mrad): ', e12.5)
11485 write (16, 299) alphaz, betaz, emitz
11486 299
format (4x,
' Longitudinal direction :', /, 6x,
' alpha: ', e12.5,
' beta(deg/keV): ', e12.5, &
11487 ' emit(pi*deg*keV): ', e12.5)
11498 call rlux(vecx, len)
11499 r1 = 2.*vecx(1) - 1.
11500 call rlux(vecx, len)
11501 r3 = 2.*vecx(1) - 1.
11502 call rlux(vecx, len)
11503 r6 = 2.*vecx(1) - 1.
11505 rho = r1**2 + r3**2 + r6**2
11506 if (rho>1)
go to 150
11507 152
call rlux(vecx, len)
11508 r2 = 2.*vecx(1) - 1.
11510 if ((r1*r1+r2*r2)>1.)
go to 152
11511 153
call rlux(vecx, len)
11512 r4 = 2.*vecx(1) - 1.
11514 if ((r4*r4+r3*r3)>1.)
go to 153
11515 180
call rlux(vecx, len)
11516 r5 = 2.*vecx(1) - 1.
11518 if ((r6*r6+r5*r5)>1.)
go to 180
11530 1500
call rlux(vecx, len)
11531 r1 = 2.*vecx(1) - 1.
11532 call rlux(vecx, len)
11533 r2 = 2.*vecx(1) - 1.
11535 rho = r1*r1 + r2*r2
11536 if (rho>1)
go to 1500
11537 1530
call rlux(vecx, len)
11538 r3 = 2.*vecx(1) - 1.
11539 call rlux(vecx, len)
11540 r4 = 2.*vecx(1) - 1.
11542 if ((r4*r4+r3*r3)>1.)
go to 1530
11543 1800
call rlux(vecx, len)
11544 r5 = 2.*vecx(1) - 1.
11545 call rlux(vecx, len)
11546 r6 = 2.*vecx(1) - 1.
11548 if ((r6*r6+r5*r5)>1.)
go to 1800
11550 rho = r1**2 + r2**2 + r3**2 + r4**2 + r5**2 + r6**2
11551 if (rho>1.0)
go to 1500
11566 14
call gcern(len, s, am, vec)
11568 call gcern(len, s, am, vec)
11570 call gcern(len, s, am, vec)
11573 rho = r1**2 + r3**2 + r6**2
11574 if (rho>1)
go to 14
11575 16
call gcern(len, s, am, vec)
11578 if ((r1*r1+r2*r2)>1.)
go to 16
11579 17
call gcern(len, s, am, vec)
11582 if ((r4*r4+r3*r3)>1.)
go to 17
11583 22
call gcern(len, s, am, vec)
11586 if ((r6*r6+r5*r5)>1.)
go to 22
11601 101
call gcern(len, s, am, vec)
11603 call gcern(len, s, am, vec)
11606 rho = r1*r1 + r2*r2
11607 if (rho>1)
go to 101
11608 112
call gcern(len, s, am, vec)
11610 call gcern(len, s, am, vec)
11613 if ((r3*r3+r4*r4)>1.)
go to 112
11614 113
call gcern(len, s, am, vec)
11616 call gcern(len, s, am, vec)
11619 if ((r6*r6+r5*r5)>1.)
go to 113
11622 rho = r1**2 + r2**2 + r3**2 + r4**2 + r5**2 + r6**2
11623 if (rho>1.0)
go to 101
11635 call rlux(vecx, len)
11636 r1 = 2.*vecx(1) - 1.
11637 call rlux(vecx, len)
11638 r3 = 2.*vecx(1) - 1.
11640 rho = r1**2 + r3**2
11641 if (rho>1)
go to 1566
11642 1525
call rlux(vecx, len)
11643 r2 = 2.*vecx(1) - 1.
11645 if ((r1*r1+r2*r2)>1.)
go to 1525
11646 1535
call rlux(vecx, len)
11647 r4 = 2.*vecx(1) - 1.
11649 if ((r4*r4+r3*r3)>1.)
go to 1535
11651 rho = r1**2 + r2**2 + r3**2 + r4**2
11652 if (rho>1.0)
go to 1566
11655 call rlux(vecx, len)
11656 r5 = 2.*vecx(1) - 1.
11657 call rlux(vecx, len)
11658 r6 = 2.*vecx(1) - 1.
11672 call rgaus2(sig, y1, y2, y3, y4)
11674 call rlux(vecx, len)
11675 r5 = 2.*vecx(1) - 1.
11676 call rlux(vecx, len)
11677 r6 = 2.*vecx(1) - 1.
11687 y1x = abs(cord(2,1))
11688 y2x = abs(cord(2,2))
11689 y3x = abs(cord(2,3))
11690 y4x = abs(cord(2,4))
11692 if (abs(cord(i,1))>y1x) y1x = abs(cord(i,1))
11693 if (abs(cord(i,2))>y2x) y2x = abs(cord(i,2))
11694 if (abs(cord(i,3))>y3x) y3x = abs(cord(i,3))
11695 if (abs(cord(i,4))>y4x) y4x = abs(cord(i,4))
11698 cord(i, 1) = cord(i, 1)/y1x
11699 cord(i, 2) = cord(i, 2)/y2x
11700 cord(i, 3) = cord(i, 3)/y3x
11701 cord(i, 4) = cord(i, 4)/y4x
11704 call corre(imax, imax)
11707 tcorct = abs(.5*cord(2,6)*ttmax)
11710 fo(1, i) = .5*cord(i, 5)*dmax
11711 fo(2, i) = .5*cord(i, 1)*ymax
11712 fo(3, i) = .5*cord(i, 2)*tmax
11713 fo(4, i) = .5*cord(i, 3)*zmax
11714 fo(5, i) = .5*cord(i, 4)*pmax
11715 fo(6, i) = .5*cord(i, 6)*ttmax
11716 if (abs(fo(6,i))>tcorct) tcorct = abs(fo(6,i))
11733 tcorct = ttmax/tcorct
11737 fo(6, i) = fo(6, i)*tcorct
11742 write (16, 8) loi, imax
11743 8
format (8x,
' ****law ', i2,
' with ', i6,
' particles', /)
11745 end subroutine monte 11750 subroutine rgaus2(sigma, y1, y2, y3, y4)
11751 implicit real *8(a-h, o-z)
11755 do while ((w1>=1.0) .or. (w1==0.))
11756 call rlux(vecx, len)
11757 x1 = 2.0*vecx(1) - 1.0
11758 call rlux(vecx, len)
11759 x3 = 2.0*vecx(1) - 1.0
11762 do while ((w2>=1.0) .or. (w2==0.))
11763 call rlux(vecx, len)
11764 x2 = 2.0*vecx(1) - 1.0
11765 call rlux(vecx, len)
11766 x4 = 2.0*vecx(1) - 1.0
11769 w1 = sigma*sqrt((-2.0*log(w1))/w1)
11770 w2 = sigma*sqrt((-2.0*log(w2))/w2)
11827 subroutine rlux(rvec, lenv)
11828 implicit real *8(a-h, o-z)
11829 dimension rvec(lenv)
11831 dimension seeds(24), iseeds(24)
11832 parameter(maxlev=4, lxdflt=3)
11833 dimension ndskip(0:maxlev)
11835 parameter(twop12=4096., igiga=1000000000, jsdflt=314159265)
11836 parameter(itwo24=2**24, icons=2147483563)
11837 save notyet, i24, j24, carry, seeds, twom24, twom12, luxlev
11838 save nskip, ndskip, in24, next, kount, mkount, inseed
11841 data notyet, luxlev, in24, kount, mkount/.true., lxdflt, 0, 0, 0/
11842 data i24, j24, carry/24, 10, 0./
11845 data ndskip/0, 24, 73, 199, 365/
11856 write (16,
'(A,I12)')
' RANLUX DEFAULT INITIALIZATION: ', jseed
11858 nskip = ndskip(luxlev)
11863 write (16,
'(A,I2,A,I4)')
' RANLUX DEFAULT LUXURY LEVEL = ', luxlev,
' p =', lp
11866 twom24 = twom24*0.5
11868 jseed = 40014*(jseed-k*53668) - k*12211
11869 if (jseed<0) jseed = jseed + icons
11870 iseeds(i) = mod(jseed, itwo24)
11872 twom12 = twom24*4096.
11874 seeds(i) =
real(iseeds(i))*twom24
11881 if (seeds(24)==0.) carry = twom24
11889 uni = seeds(j24) - seeds(i24) - carry
11901 if (uni<twom12)
then 11902 rvec(ivec) = rvec(ivec) + twom24*seeds(j24)
11904 if (rvec(ivec)==0.) rvec(ivec) = twom24*twom24
11910 kount = kount + nskip
11912 uni = seeds(j24) - seeds(i24) - carry
11925 kount = kount + lenv
11926 if (kount>=igiga)
then 11927 mkount = mkount + 1
11928 kount = kount - igiga
11931 end subroutine rlux 11943 subroutine rluxin(isdext)
11944 implicit real *8(a-h, o-z)
11945 dimension seeds(24), isdext(25)
11946 parameter(maxlev=4, lxdflt=3)
11947 dimension ndskip(0:maxlev)
11949 parameter(twop12=4096., igiga=1000000000, jsdflt=314159265)
11950 parameter(itwo24=2**24, icons=2147483563)
11951 save notyet, i24, j24, carry, seeds, twom24, twom12, luxlev
11952 save nskip, ndskip, in24, next, kount, mkount, inseed
11955 data notyet, luxlev, in24, kount, mkount/.true., lxdflt, 0, 0, 0/
11956 data i24, j24, carry/24, 10, 0./
11959 data ndskip/0, 24, 73, 199, 365/
11970 twom24 = twom24*0.5
11973 twom12 = twom24*4096.
11974 write (16,
'(A)')
'FULL INITIALIZATION OF RANLUX WITH 25',
' INTEGERS' 11975 write (16,
'(5X,5I12)') isdext
11977 seeds(i) =
real(isdext(i))*twom24
11980 if (isdext(25)<0) carry = twom24
11981 isd = iabs(isdext(25))
11982 i24 = mod(isd, 100)
11984 j24 = mod(isd, 100)
11986 in24 = mod(isd, 100)
11989 if (luxlev<=maxlev)
then 11990 nskip = ndskip(luxlev)
11991 write (6,
'(A,I2)')
'RANLUX LUXURY LEVEL SET BY RLUXIN TO: ', luxlev
11992 else if (luxlev>=24)
then 11993 nskip = luxlev - 24
11994 write (6,
'(A,I5)')
'RANLUX P-VALUE SET BY RLUXIN TO:', luxlev
11996 nskip = ndskip(maxlev)
11997 write (6,
'(A,I5)')
'RANLUX ILLEGAL LUXURY RLUXIN: ', luxlev
12011 subroutine rluxut(isdext)
12012 implicit real *8(a-h, o-z)
12013 dimension seeds(24), isdext(25)
12014 parameter(maxlev=4, lxdflt=3)
12015 dimension ndskip(0:maxlev)
12016 parameter(twop12=4096., igiga=1000000000, jsdflt=314159265)
12017 parameter(itwo24=2**24, icons=2147483563)
12018 save notyet, i24, j24, carry, seeds, luxlev
12019 save ndskip, in24, kount, mkount
12022 data notyet, luxlev, in24, kount, mkount/.true., lxdflt, 0, 0, 0/
12023 data i24, j24, carry/24, 10, 0./
12026 data ndskip/0, 24, 73, 199, 365/
12034 isdext(i) = int(seeds(i)*twop12*twop12)
12036 isdext(25) = i24 + 100*j24 + 10000*in24 + 1000000*luxlev
12037 if (carry>0.) isdext(25) = -isdext(25)
12052 subroutine rluxat(lout, inout, k1, k2)
12053 implicit real *8(a-h, o-z)
12054 parameter(maxlev=4, lxdflt=3)
12055 save notyet, luxlev
12056 save in24, kount, mkount, inseed
12059 data notyet, luxlev, in24, kount, mkount/.true., lxdflt, 0, 0, 0/
12079 subroutine rluxgo(lux, ins, k1, k2)
12080 implicit real *8(a-h, o-z)
12081 dimension seeds(24), iseeds(24)
12082 parameter(maxlev=4, lxdflt=3)
12083 dimension ndskip(0:maxlev)
12085 parameter(twop12=4096., igiga=1000000000, jsdflt=314159265)
12086 parameter(itwo24=2**24, icons=2147483563)
12087 save notyet, i24, j24, carry, seeds, twom24, twom12, luxlev
12088 save nskip, ndskip, in24, next, kount, mkount, inseed
12091 data notyet, luxlev, in24, kount, mkount/.true., lxdflt, 0, 0, 0/
12092 data i24, j24, carry/24, 10, 0./
12095 data ndskip/0, 24, 73, 199, 365/
12104 else if (lux<=maxlev)
then 12106 else if (lux<24 .or. lux>2000)
then 12108 write (6,
'(A,I7)')
'RANLUX ILLEGAL LUXURY RLUXGO: ', lux
12112 if (lux==ndskip(ilx)+24) luxlev = ilx
12115 if (luxlev<=maxlev)
then 12116 nskip = ndskip(luxlev)
12117 write (16,
'(A,I2,A,I4)')
'RANLUX LUXURY LEVEL SET BY RLUXGO :', luxlev,
' P=', nskip + 24
12119 nskip = luxlev - 24
12120 write (16,
'(A,I5)')
'RANLUX P-VALUE SET BY RLUXGO TO:', luxlev
12123 if (ins<0)
write (6,
'(A)')
' Illegal initialization by RLUXGO, negative input seed' 12126 write (16,
'(A,3I12)')
'RANLUX INITIALIZED BY ',
'RLUXGO FROM SEEDS', jseed, k1, k2
12129 write (16,
'(A)')
'RANLUX INITIALIZED BY RLUXGO FROM DEFAULT',
' SEED' 12135 twom24 = twom24*0.5
12137 jseed = 40014*(jseed-k*53668) - k*12211
12138 if (jseed<0) jseed = jseed + icons
12139 iseeds(i) = mod(jseed, itwo24)
12141 twom12 = twom24*4096.
12143 seeds(i) =
real(iseeds(i))*twom24
12150 if (seeds(24)==0.) carry = twom24
12157 do iouter = 1, k2 + 1
12159 if (iouter==k2+1) inner = k1
12161 uni = seeds(j24) - seeds(i24) - carry
12174 in24 = mod(kount, nskip+24)
12176 izip = mod(igiga, nskip+24)
12177 izip2 = mkount*izip + in24
12178 in24 = mod(izip2, nskip+24)
12182 write (6,
'(A/A,3I11,A,I5)')
' Error in RESTARTING with RLUXGO:',
' The values', ins, k1, k2, &
12183 ' cannot occur at luxury level', luxlev
12196 subroutine gcern(len, s, am, v)
12197 implicit real *8(a-h, o-z)
12203 call rlux(vecx, len)
12207 v = (a-float(ntir)/2.)*s + am
12209 end subroutine gcern 12215 implicit real *8(a-h, o-z)
12216 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
12217 common /consta/vl, pi, xmat, rpel, qst
12218 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
12219 common /speda/dave, idave
12220 common /dyn/tref, vref
12221 common /faisc/f(10, iptsz), imax, ngood
12222 common /objet/fo(9, iptsz), imaxo
12223 common /qmoyen/qmoy
12225 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
12226 common /etcom/cog(8), exten(17), fd(iptsz)
12227 common /tapes/in, ifile, meta
12228 common /isxpyp/iflag
12229 common /mcs/imcs, ncstat, cstat(20)
12230 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
12231 common /dyni/vrefi, trefi, fhinit, acpt
12232 common /strip/atm, qs, atms, ths, qop, sqst(6), anp, nqst
12233 common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
12234 common /trace3e/tracebi(6), traceei(3)
12235 common /t3dfld/fldctr(15), zend(15), t3d
12237 character *128 trace3h, trace3t, tif
12241 if (iflag==0 .or. iflag==100)
write (16, *)
'Standard file, phase in rad' 12242 if (iflag==1 .or. iflag==101)
write (16, *)
'File with charge state and rest ',
'mass, phase in rad' 12243 if (iflag==2 .or. iflag==102)
write (16, *)
'File with several charge states',
', phase in rad' 12244 if (iflag==10 .or. iflag==110)
write (16, *)
'Standard file, phase in ns' 12245 if (iflag==11 .or. iflag==111)
write (16, *)
'File with charge state and rest',
' mass, phase in ns' 12246 if (iflag==12 .or. iflag==112)
write (16, *)
'File with several charge states',
', phase in ns' 12248 read (in, *) freq, tofini
12249 write (16, *)
'Frequency [MHz]:', freq
12250 fh = 2.*pi*freq*1.e06
12252 read (in, *) uem, atm
12257 read (in, *) enedep, qst
12258 tofini = tofini*pi/(180.*fh)
12259 gdep = enedep/xmat + 1.
12260 bdep = sqrt(1.-1./(gdep*gdep))
12266 boro = 3.3356*xmat*bdep*gdep/qst
12267 write (16, 101) uem, atm, qst, tofini, enedep, boro
12268 101
format (
' **** unit mass: ', e12.5,
' MeV, mass units: ', f6.1, /,
' **** reference charge ', f4.1, &
12269 ' time of flight ', e12.5,
' sec', /,
' **** reference : energy ', e12.5,
' MeV momentum ', e12.5,
' kG.cm')
12271 read (55, *) imax, dum, dum
12272 if (imax+2>iptsz)
then 12273 write (16, *)
'too many particles ' 12277 if (iflag==0 .or. iflag==10)
read (55, *)((f(i,j),i=1,6), j=1, imax)
12280 if (iflag==1 .or. iflag==11)
read (55, *)((f(i,j),i=1,6), dum1, dum2, j=1, imax)
12283 if (ncstat==1) cstat(1) = qst
12284 if (iflag==2 .or. iflag==12)
then 12286 read (55, *)(f(i,1), i=1, 7)
12289 read (55, *)(f(i,j), i=1, 7)
12292 if (f(7,j)==cstat(k))
then 12296 if (mcstat==0)
then 12297 ncstat = ncstat + 1
12298 cstat(ncstat) = f(7, j)
12301 write (16, *)
'Number of charge states: ', ncstat
12302 write (16, *)
'Charge states: ', (cstat(j), j=1, ncstat)
12303 if (ncstat>1) imcs = 1
12307 tracebi(6) = tracebi(6)*sqrt(atm)
12308 write (tif, 901)(tracebi(i), i=1, 6)
12309 901
format (
' BEAMI(1)= ', 5(f12.6,1x), f12.4)
12311 trace3h(kt3h) = tif
12312 traceei(3) = traceei(3)/sqrt(atm)
12313 write (tif, 902)(traceei(i), i=1, 3)
12314 902
format (
' EMITI(1)= ', f12.6, 1x, f12.6, 1x, f12.4)
12316 trace3h(kt3h) = tif
12317 write (tif, 903) uem*atm/qst, fhinit/2./pi/1.e6
12318 903
format (
' ER= ', e16.7,
', Q=1 FREQ= ', e14.7)
12320 trace3h(kt3h) = tif
12321 write (tif, 7001) enedep/qst
12322 7001
format (
' W= ', f12.4)
12324 trace3h(kt3h) = tif
12332 subroutine intfac(tofini)
12333 implicit real *8(a-h, o-z)
12334 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
12335 common /etcom/cog(8), exten(17), fd(iptsz)
12336 common /shif/dtiph, shift
12337 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
12338 common /faisc/f(10, iptsz), imax, ngood
12339 common /objet/fo(9, iptsz), imaxo
12340 common /qmoyen/qmoy
12342 common /dyn/tref, vref
12343 common /consta/vl, pi, xmat, rpel, qst
12344 common /tapes/in, ifile, meta
12345 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
12346 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
12347 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
12348 common /speda/dave, idave
12349 common /isxpyp/iflag
12350 common /mcs/imcs, ncstat, cstat(20)
12351 dimension foo(20, 9), ndp(20)
12352 common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
12353 common /trace3e/tracebi(6), traceei(3)
12354 common /t3dfld/fldctr(15), zend(15), t3d
12356 character *128 trace3h, trace3t, tif
12357 logical shift, chasit, dave
12367 if (iflag==2 .or. iflag==12) imcs = 1
12373 fo(7, i) = f(6, j) + xmat
12374 if (iflag<=1) fo(9, i) = qst
12375 if (iflag==2) fo(9, i) = f(7, i)
12378 fo(1, i) = float(j+1)
12380 fo(3, i) = f(2, j)*1000.
12382 fo(5, i) = f(4, j)*1000.
12383 fo(6, i) = tofini + f(5, j)/fh
12388 fo(7, i) = f(6, j) + xmat
12389 if (iflag<=11) fo(9, i) = qst
12390 if (iflag==12) fo(9, i) = f(7, i)
12393 fo(1, i) = float(j+1)
12395 fo(3, i) = f(2, j)*1000.
12397 fo(5, i) = f(4, j)*1000.
12398 fo(6, i) = tofini + f(5, j)*1.e-09
12403 if (iflag==0 .or. iflag==1 .or. iflag==10 .or. iflag==11)
then 12411 foo(1, j) = foo(1, j) + fo(j, i)
12417 trace3h(kt3h) =
'ERROR: RDBEAM reads more than 1 charge state' 12426 if (fo(9,i)==cstat(k))
then 12427 ndp(k) = ndp(k) + 1
12429 foo(k, j) = foo(k, j) + fo(j, i)
12437 foo(k, j) = foo(k, j)/float(ndp(k))
12441 if (iflag==0 .or. iflag==1 .or. iflag==10 .or. iflag==11)
then 12443 gref = foo(1, 7)/xmat
12444 bref = sqrt(1.-1./(gref*gref))
12445 xe = (gref-1.)*xmat
12447 bor = 3.3356*xmat*bref*gref/qst
12448 write (16, *)
'**** COG : energy ', xe,
' MeV momentum ', boro,
' kG.cm' 12451 gref = foo(k, 7)/xmat
12452 bref = sqrt(1.-1./(gref*gref))
12453 xe = (gref-1.)*xmat
12455 bor = 3.3356*xmat*bref*gref/cstat(k)
12456 write (16, *)
' Q: ', cstat(k),
' COG : energy ', xe,
' MeV momentum ', bor,
' kG.cm' 12491 subroutine stapl(zpos)
12492 implicit real *8(a-h, o-z)
12493 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
12494 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
12495 common /pltprf1/sprww(3000), eprfw(3000), eprnx(3000), eprny(3000), sprfz(3000)
12496 common /pltprf2/sxmn(3000), sxmx(3000), symn(3000), symx(3000), stmn(3000), stmx(3000), spmn(3000), spmx(3000), &
12497 swmn(3000), swmx(3000), disprx(3000), dispry(3000), dispcx(3000), dispcy(3000)
12498 common /etcom/cog(8), exten(17), fd(iptsz)
12499 common /consta/vl, pi, xmat, rpel, qst
12500 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
12501 common /faisc/f(10, iptsz), imax, ngood
12502 common /grot/rzot, izrot
12505 if (izrot)
call zrotap(-rzot)
12510 bcog = sqrt(1.-1./(gcog*gcog))
12513 qdisp = 2.*sqrt(exten(1))
12514 qmd = exten(1)*exten(3) - exten(2)*exten(2)
12515 delw = encog*encog*bcog**4
12517 sqmdv = 4.*pi*sqrt(qmdv)
12518 eprfw(iprf) = sqmdv*1.e12/(pi*fh)
12519 sprfx(iprf) = 2.*sqrt(exten(4))
12520 sprfy(iprf) = 2.*sqrt(exten(6))
12521 trqtx = exten(4)*exten(5) - exten(8)*exten(8)
12522 trqpy = exten(6)*exten(7) - exten(9)*exten(9)
12523 surxth = 4.*pi*sqrt(trqtx)
12524 suryph = 4.*pi*sqrt(trqpy)
12525 eprnx(iprf) = bcog*surxth*10./(pi*sqrt(1.-bcog*bcog))
12526 eprny(iprf) = bcog*suryph*10./(pi*sqrt(1.-bcog*bcog))
12531 dispcx(iprf) = 0.01*exten(15)/exten(17)
12532 dispcy(iprf) = 0.01*exten(16)/exten(17)
12539 chpmx = f(6, 1) - tcog
12540 chpmn = f(6, 1) - tcog
12541 chwmx = f(7, 1) - encog
12542 chwmn = f(7, 1) - encog
12544 gpai = f(7, i)/xmat
12545 bpai = sqrt(1.-1./(gpai*gpai))
12546 fdp = (gpai*bpai)/(gcog*bcog) - 1.
12547 trqfi = trqfi + fdp*fdp
12548 tf = (tcog-f(6,i))*bpai*vl
12550 if (f(2,i)>chxmx) chxmx = f(2, i)
12551 if (f(2,i)<chxmn) chxmn = f(2, i)
12552 if (f(4,i)>chymx) chymx = f(4, i)
12553 if (f(4,i)<chymn) chymn = f(4, i)
12554 if (f(6,i)-tcog>chpmx)
then 12555 chpmx = f(6, i) - tcog
12556 chdmx = chpmx*fh*180./pi
12558 if (f(6,i)-tcog<chpmn)
then 12559 chpmn = f(6, i) - tcog
12560 chdmn = chpmn*fh*180./pi
12562 if (f(7,i)-encog>chwmx) chwmx = f(7, i) - encog
12563 if (f(7,i)-encog<chwmn) chwmn = f(7, i) - encog
12565 trqfi = trqfi/float(ngood)
12566 tof = tof/float(ngood)
12567 sprfz(iprf) = sqrt(tof)
12568 cmult = (gcog+1.)/gcog
12569 sprfw(iprf) = 2.*sqrt(trqfi)*cmult
12570 sprfp(iprf) = 2.*sqrt(exten(3))*180./pi
12571 sprww(iprf) = cog(1) - xmat
12573 sprfl(iprf) = zpos/1000.
12574 sprng(iprf) = ngood
12576 sxmx(iprf) = chxmx*10.
12577 sxmn(iprf) = chxmn*10.
12578 symx(iprf) = chymx*10.
12579 symn(iprf) = chymn*10.
12588 if (izrot)
call zrotap(-rzot)
12590 end subroutine stapl 12596 implicit real *8(a-h, o-z)
12597 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
12598 common /pltprf1/sprww(3000), eprfw(3000), eprnx(3000), eprny(3000), sprfz(3000)
12599 common /pltprf2/sxmn(3000), sxmx(3000), symn(3000), symx(3000), stmn(3000), stmx(3000), spmn(3000), spmx(3000), &
12600 swmn(3000), swmx(3000), disprx(3000), dispry(3000), dispcx(3000), dispcy(3000)
12604 99
format (1x,
'# l(m) ', 1x,
' x(mm) ', 1x,
' y(mm) ', 3x,
' z(deg) ', 1x,
' z(mm) ', 2x, &
12605 'emx(mm.mrd)', 2x,
'emy(mm.mrd) ', 1x,
'emz(KeV.ns)', 2x,
'energy(MeV) ', 1x,
'#particles', 2x,
'xmin(mm)', 5x, &
12606 'xmax(mm)', 5x,
'ymin(mm)', 5x,
'ymax(mm)', 5x,
'tmin(s)', 6x,
'tmax(s)', 5x,
'phmin(deg)', 4x,
'phmax(deg)', &
12607 3x,
'Wmin(MeV)', 4x,
'Wmax(MeV)', 4x,
'Dx(m)', 8x,
'Dy(m)')
12611 sprx = sprfx(i)*10./2.
12612 spry = sprfy(i)*10./2.
12614 sprz = sprfz(i)*10.
12615 write (71, 100) sprfl(i), sprx, spry, sprp, sprz, eprnx(i)/4., eprny(i)/4., eprfw(i), sprww(i), int(sprng(i)), &
12616 sxmn(i), sxmx(i), symn(i), symx(i), stmn(i), stmx(i), spmn(i), spmx(i), swmn(i), swmx(i), dispcx(i), dispcy(i)
12619 100
format (9(1x,e12.5), 1x, i7, 3x, 12(1x,e12.5))
12636 implicit real *8(a-h, o-z)
12637 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
12638 common /ttfs/dynt(maxcell), dyntp(maxcell), dyntpp(maxcell), dyne0(maxcell), dynph(maxcell), dynlg(maxcell), &
12641 common /midgap/enmil, vapmi
12642 common /azmtch/dlg, xmcph, xmce
12643 common /azlist/icont, iprin
12644 common /itvole/itvol, imamin
12645 common /func/a(200), ylg, atte, ncel, nharm
12647 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
12648 common /ttfc1/t3k, t4k, s3k, s4k
12649 common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
12650 common /jacob/gaks, gaps
12651 common /iter1/dxdki, dphii, phi, dkmske, dkmsphi, retph, xkmi, xkm, dxk00, tke, t1ke, ske, s1ke, phiwc, xk1i, &
12653 common /faisc/f(10, iptsz), imax, ngood
12654 common /qmoyen/qmoy
12656 common /cdek/dwp(iptsz)
12657 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
12658 common /consta/vl, pi, xmat, rpel, qst
12659 common /dyn/tref, vref
12660 common /compt/nrres, nrtre, nrbunc, nrdbun
12661 common /compt1/ndtl, ncavmc, ncavnm
12662 common /fene/wdisp, wphas, wx, wy, rlim, ifw
12663 common /tapes/in, ifile, meta
12664 common /ranec1/dummy(6)
12665 common /etcom/cog(8), exten(17), fd(iptsz)
12666 common /speda/dave, idave
12667 common /shif/dtiph, shift
12668 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
12669 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
12672 common /mode/eflvl, rflvl
12673 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
12674 common /appel/irstay, ilost, iavp, ispcel
12676 common /femt/iemgrw, iemqesg
12677 common /aerp/vphase, vfield, ierpf
12678 common /tofev/ttvols
12679 common /pstpla/tstp
12680 common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
12681 character *128 trace3h, trace3t, tif
12687 logical iesp, irstay, iavp, ispcel, iemgrw
12691 logical shift, chasit, itvol, imamin, dave, ichaes
12692 dimension etcell(maxcell)
12705 write (6, 8254) nrtre, ndtl, cr
12706 8254
format (
'Transport element:', i5,
' Accelerating gap :', i5, a1, $)
12707 write (16, *)
'ACCELERATING GAP N :', ndtl
12708 read (in, *)(etcell(iet), iet=1, 16)
12711 if (fakt==0.) fakt = 1.e-12
12712 fh = fh*2.*pi*1000000.
12717 ye0 = etcell(11)/100.
12719 t0 = etcell(5)*ylg*ye0
12720 tp0 = -etcell(6)*ylg*ylg*ye0
12721 tpp0 = -etcell(14)*ylg*ylg*ylg*ye0
12734 tppk0 = ylg*ylg*t0/4. - tpp0
12735 sppk0 = -ylg*tp0/2.
12753 tppk0 = ylg*ylg*t0/4. - tpp0
12754 sppk0 = -ylg*tp0/2.
12768 dav1(idav, 1) = ylg*10.
12769 dav1(idav, 2) = ye0*100.
12770 tstp = (davtot+ylg*xpsc)*10.
12771 davtot = davtot + ylg
12772 dav1(idav, 24) = davtot*10.
12776 if (iprf==1)
call stapl(dav1(idav,24))
12783 bcog = sqrt(1.-1./(gcog*gcog))
12788 gamref = 1./sqrt(1.-(beref*beref))
12789 enref = xmat*gamref
12790 trefdg = tref*fh*180./pi
12791 tcogdg = tcog*fh*180./pi
12800 trefdg = tref*fh*180./pi
12801 tcogdg = tcog*fh*180./pi
12806 if (itvol) ttvol = ttvols*fh
12822 if (dav1(idav,3)==1.)
write (16, *)
' ****reference and cog are different' 12823 if (dav1(idav,3)==0.)
write (16, *)
' **** reference and cog coincide ' 12825 178
format (/,
' DYNAMICS AT THE INPUT ', /, 5x,
' BETA GAMMA ENERGY(MeV) ', &
12826 ' TOF(deg) TOF(sec)')
12827 write (16, 1788) bcog, gcog, ecog - xmat, tcogdg, tcog
12828 1788
format (
' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
12829 write (16, 165) beref, gamref, enref - xmat, trefdg, tref
12830 165
format (
' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
12838 gamref = 1./sqrt(1.-(beref*beref))
12840 dphete = etcell(12)
12841 dphase = etcell(12)*pi/180.
12861 ddw = aqst*t0*cos(dphase)
12862 enrefs = enref + ddw
12864 bets = sqrt(1.-1./(gams*gams))
12866 bemy = (gams*bets+gamref*beref)/(gams+gamref)
12876 fpk0 = (tp0*tp0+t0*tpp0)/(t0*t0)
12877 fpk1 = 2.*tp0**2/(t0*t0)
12878 fpk = 2.*(fpk0-fpk1)
12879 pcrest = atan(-sk/tk)
12880 ddw = aqst*(tk*cos(pcrest)-sk*sin(pcrest))/2.
12881 if (ddw<0.) pcrest = pcrest + pi
12885 write (16, 1555) fh/(2.*pi), ylg, dphase*180./pi
12886 1555
format (4x,
'FREQENCY :', e12.5,
' Hertz', /, 4x,
'GAP LENGTH :', e12.5,
' cm', /, 4x, &
12887 'PHASE of RF (middle of the gap) :', e12.5,
'deg', /)
12907 fpk = 2.*(fpk0-fpk1)
12911 if (it==1) phslip = -4.*atan(3.2*dts/eqvl)
12912 if (phslip/=0.)
then 12915 gx = 1./tan(til2) - 1./til2
12916 gpx = -1./(sin(til2)*sin(til2)) + 1./(til2*til2)
12917 gppx = 2.*cos(til2)/(sin(til2)**3) - 2./(til2*til2*til2)
12918 hx = gpx/(gx*gx) - 2.*fpk/(fk1**2)
12919 dhx = -(2.*gx*gpx*gpx-gx*gx*gppx)/(gx**4)
12920 til2 = til2 - hx/dhx
12921 eqvl = sqrt(abs(2.*fpk/gpx))
12922 if (abs(hx)<=1.e-05)
go to 556
12928 asdl = peqvl - eqvl/2.
12931 saphi = sapho - pcrest + ttvol
12933 f0 =
xitl0(gamref, gams, bemy, saphi, aqst)
12934 delwrm = (f0-gamref)*xmat
12935 enrs = enref + delwrm
12937 bets = sqrt(1.-1./(gams*gams))
12939 coeph = fh*aqst/(vl*xmat)
12940 f2 =
xitl2(gamref, gams, bemy, saphi, aqst)
12942 xkm = delphr/eqvl + xk2*(1.+asdl/eqvl) - xk1*asdl/eqvl
12946 tk = tk0 + dkg*tpk0 + dkg*dkg*tppk0/2. + dkg**3*tp3k0/6. + dkg**4*tp4k0/24.
12947 t1k = tpk0 + dkg*tppk0 + dkg*dkg*tp3k0/2. + dkg**3*tp4k0/6.
12948 t2k = tppk0 + dkg*tp3k0 + dkg*dkg*tp4k0/2.
12949 t3k = tp3k0 + dkg*tp4k0
12951 sk = sk0 + dkg*spk0 + dkg*dkg*sppk0/2. + dkg**3*sp3k0/6. + dkg**4*sp4k0/24.
12952 s1k = spk0 + dkg*sppk0 + dkg*dkg*sp3k0/2. + dkg**3*sp4k0/6.
12953 s2k = sppk0 + dkg*sp3k0 + dkg*dkg*sp4k0/2.
12954 s3k = sp3k0 + dkg*sp4k0
12957 pcrest = atan(-sk/tk)
12958 ddw = aqst*(tk*cos(pcrest)-sk*sin(pcrest))/2.
12959 if (ddw<0.) pcrest = pcrest + pi
12962 sqcttf = til2*sqrt(tk*tk+sk*sk)/sin(til2)*2.
12964 cfh = fh/(vl*2.*xmat)
12965 ckh = qmoy*qmoy/(4.*xmat*xmat)
12966 call gap(gamref, saphi, gams, delphr)
12969 phares = saphi + fh*ylg/vref + delphr
12970 trefs = tref + ylg/(bets*vl) + delphr/fh
12971 phared = (phares-saphi)*180./pi
12972 tredg = fh*trefs*180./pi
12973 write (16, *)
' PARAMETERS RELATING TO THE REFERENCE PARTICLE ' 12974 write (16, *)
'************************************************' 12975 write (16, *)
' ENERGY GAIN(MeV): ', delwrm,
' TOF(DEG) ', tredg
12977 write (16, *)
' CREST PHASE OF RF (DG): ', pcrest*180./pi
12978 write (16, *)
' PHASE OF RF AT THE MIDDLE (DG): ', sapho*180./pi
12979 write (16, *)
' PHASE OF RF AT THE ENTRANCE (DG): ', saphi*180./pi
12980 write (16, *)
' AVERAGE k (cm-1) (freq./velocity): ', xkm
12981 write (16, *)
' TRANSIT TIME FACTORS (MeV-cm):' 12982 write (16, *)
' T dT/dk d2T/dk2 ', tk, t1k, t2k
12983 write (16, *)
' S dS/dk d2S/dk2 ', sk, s1k, s2k
12984 write (16, *)
' PHASE SLIP(DEG) ', phslip*180./pi
12986 write (16, *)
' PARAMETERS RELATING TO THE EQUIVALENT FIELD ' 12987 write (16, *)
'************************************************' 12988 write (16, 171) eqvl
12989 171
format (
' length :', e12.5,
' cm ')
12990 write (16, *)
' Associated drift length: ', asdl,
' cm' 12991 write (16, *)
' magnitude: ', sqcttf,
' MV/cm' 12996 bcog = sqrt(1.-1./(gcog*gcog))
13001 dav1(idav, 37) = saphi*180./pi
13006 dav1(idav, 38) = dphete
13010 3777
format (/, 3x, 3(
'*'),
' DYNAMICS AT THE OUTPUT: ', /, 5x,
' BETA dW(MeV) ENERGY(MeV) ', &
13011 ' TOF(deg) TOF(sec)')
13012 write (16, 3473) bets, delwrm, enrs - xmat, fh*trefs*180./pi, trefs
13013 3473
format (
' REF ', f7.5, 3x, f10.6, 3x, f8.3, 3x, e12.5, 3x, e12.5)
13014 write (16, 1789) bcog, encog - enold, encog - xmat, tcog*fh*180./pi, tcog
13015 1789
format (
' COG ', f7.5, 3x, f10.6, 3x, f8.3, 3x, e12.5, 3x, e12.5)
13019 write (tif, 6001) kt3t, kt3t, 10.*etcell(4)/2.
13020 6001
format (
' nt(', i4,
')= 1, a(1,', i4,
')=', f12.6)
13021 trace3t(kt3t) = tif
13023 trphase = etcell(12)
13025 tre0tl = delwrm/cos(pi*trphase/180.)
13027 write (tif, 6005) kt3t, kt3t, tre0tl, trphase, fid
13028 6005
format (
' nt(', i4,
')=10, a(1,', i4,
')=', f9.5,
' , ', f9.2,
', 1., 1.,', f5.3,
',')
13029 trace3t(kt3t) = tif
13032 write (tif, 6001) kt3t, kt3t, 10.*etcell(4)/2.
13033 trace3t(kt3t) = tif
13035 testca = exten(1)*exten(2)*exten(3)
13037 if (abs(testca)>epsil)
then 13038 qdisp = 2.*sqrt(exten(1))
13039 qmd = exten(1)*exten(3) - exten(2)**2
13040 sqmdv = 4.*pi*sqrt(qmd)
13041 surm = 4.*pi*sqrt(qmd)*180./pi
13042 qdp = 2.*sqrt(exten(3))
13043 cor12 = exten(2)/sqrt(exten(1)*exten(3))
13044 qdpde = qdp*180./pi
13056 trqtx = exten(4)*exten(5) - exten(8)**2
13057 trqpy = exten(6)*exten(7) - exten(9)**2
13058 qditax = 2.*sqrt(exten(4))
13059 qdiant = 2.*sqrt(exten(5))
13060 qditay = 2.*sqrt(exten(6))
13061 qdianp = 2.*sqrt(exten(7))
13062 surxth = 4.*pi*sqrt(trqtx)
13063 suryph = 4.*pi*sqrt(trqpy)
13080 call stapl(dav1(idav,24))
13081 dltaw = qdisp*xmat*bcog*bcog/sqrt(1.-bcog*bcog)
13089 dav1(idav, 16) = bcog*surxth*10./(pi*sqrt(1.-bcog*bcog))
13091 dav1(idav, 21) = bcog*suryph*10./(pi*sqrt(1.-bcog*bcog))
13092 dav1(idav, 25) = ndtl
13093 emns = 1.e12*sqmdv/(pi*fh)
13095 trfprt = fh*tref*180./pi
13096 tcgprt = fh*tcog*180./pi
13105 trnsms = 100.*float(ngood)/float(imax)
13106 if (ndtl==1)
write (50, *)
'# gap.dmp' 13107 if (ndtl==1)
write (50, *)
'# gap Z trans ', &
13108 'PHIs TOF(COG) COG Wcog TOF(REF) ', &
13109 ' REF Wref Ex,RMS,n Ey,RMS,n El,RMS' 13110 if (ndtl==1)
write (50, *)
'# # (m) (%) ', &
13111 '(deg) (deg) beta (MeV) (deg) ', &
13112 ' beta (MeV) (mm.mrad) (mm.mrad) (ns.keV)' 13113 write (50, 7023) ndtl, 0.01*davtot, trnsms, dphete, tcgprt, bcog, encog - xmat, trfprt, bets, enrs - xmat, &
13114 0.25*dav1(idav, 16), 0.25*dav1(idav, 21), 0.25*emns
13115 7023
format (1x, i4, 1x, e12.5, 1x, f6.2, 1x, f7.2, 1x, 2(e14.7,1x,f7.5,1x,e14.7,1x), 3(e12.5,1x))
13118 gref = 1./sqrt(1.-bets*bets)
13119 xmor = xmat*bets*gref
13120 boro = 33.356*xmor*1.e-01/qst
13121 write (16, *) ilost,
' particles are lost in element ', ndtl
13125 end subroutine etgap 13131 subroutine gap(gamref, saphi, gams, delphr)
13132 implicit real *8(a-h, o-z)
13133 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
13134 common /ttfs/dynt(maxcell), dyntp(maxcell), dyntpp(maxcell), dyne0(maxcell), dynph(maxcell), dynlg(maxcell), &
13137 common /midgap/enmil, vapmi
13138 common /azmtch/dlg, xmcph, xmce
13139 common /azlist/icont, iprin
13140 common /itvole/itvol, imamin
13141 common /func/a(200), ylg, atte, ncel, nharm
13143 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
13145 common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
13146 common /jacob/gaks, gaps
13147 common /iter1/dxdki, dphii, phi, dkmske, dkmsphi, retph, xkmi, xkm, dxk00, tke, t1ke, ske, s1ke, phiwc, xk1i, &
13150 common /iterco/yh11t, yh1k1t, yh1k01t, yh10pkt, yh11pkt, yh1p1t, h1akit, h1akimt, h1akmt, hapit, happit
13152 common /itersi/yh21t, yh2k1t, yh2k01t, yh2p1t, yh20pkt, yh21pkt, h1bkit, h1bkimt, h1bkmt, hbpit, hbppit
13153 common /tranrs/sa11, sa12, sa21, sa22, sact11, sact12, sact21, sact22
13155 common /typl1/yh1k0, yh1k1, yp1k1, yp1k2, yh1k00, yh1k01, yp1k01, yp1k02, yh10, yh11, yp11, yp12
13156 common /typl2/yh2k0, yh2k1, yp2k1, yp2k2, yh2k00, yh2k01, yp2k01, yp2k02, yh20, yh21, yp21, yp22
13157 common /typi1/ye1k0, ye1k1, ye1k2, ye1kc0, ye1kc1, ye1kc2, ye10, ye11, ye12
13158 common /typi2/ye2k0, ye2k1, ye2k2, ye2kc0, ye2kc1, ye2kc2, ye20, ye21, ye22
13159 common /thad2/h0aki, h0akim, h0akm, h0bki, h0bkim, h0bkm, h1aki, h1akim, h1akm, h1bki, h1bkim, h1bkm
13161 common /typlp1/yh1p1, yh2p1, hapi, hbpi
13163 common /typlp2/happi, hbppi
13165 common /typlpk/yh10pk, yh11pk, yh20pk, yh21pk
13168 common /typj/yfsk0, yfsk1, yfsk2, yfsp0, yfsp1, yfsp2, yfskc0, yfskc1, yfskc2, yfsck0, yfsck1, yfsck2, yfscp0, &
13169 yfscp1, yfscp2, yfs0, yfs1, yfs2
13171 common /typm/ynsk0, ynsk1, ynsk2, ynsp0, ynsp1, ynsp2, ynsk0c, ynsk1c, ynsk2c, yns0, yns1, yns2
13173 common /faisc/f(10, iptsz), imax, ngood
13174 common /qmoyen/qmoy
13176 common /beamsa/fs(7, iptsz)
13177 common /cdek/dwp(iptsz)
13178 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
13179 common /consta/vl, pi, xmat, rpel, qst
13180 common /dyn/tref, vref
13181 common /tapes/in, ifile, meta
13182 common /etcom/cog(8), exten(17), fd(iptsz)
13183 common /speda/dave, idave
13184 common /shif/dtiph, shift
13185 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
13186 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
13188 common /fene/wdisp, wphas, wx, wy, rlim, ifw
13189 common /appel/irstay, ilost, iavp, ispcel
13191 common /pstpla/tstp
13192 common /rander/ialin
13193 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
13194 logical iesp, ichaes, irstay, iavp, ispcel, ialin
13195 logical shift, chasit, itvol, imamin, dave
13218 call xtypl1(gamref, saphi, aqmoy, dcum)
13220 cxlg = aqmoy/(4.*xmat*eqvl)
13222 dkmp = (gami*gami-1.)**(1.5)*(gams*gams-1.)**(-1.5)
13223 dkms = dkmp*(1.+asdl/eqvl) + yh1k01*fh0*cxlg/eqvl - asdl/eqvl
13224 dkm1 = -gaks*(gams*gams-1.)**(-1.5)*fh0*(1.+asdl/eqvl)
13226 dkmske = dkms/(1.-yh1k1*cxlg*fh0/eqvl-dkm1)
13227 call xtypl2(gamref, saphi, aqmoy, dcum)
13228 call xtyplp1(gamref, saphi, aqmoy, dcum)
13229 call xtylpk(gamref, saphi, aqmoy, dcum)
13230 dphsph1 = (yh1p1-yh21)*cxlg*fh0
13231 dkmsphi = -fh0*(gams*gams-1.)**(-1.5)*gaps*(1.+asdl/eqvl) + dphsph1/eqvl
13259 if (ichaes .and. ispcel)
then 13261 write (16, *)
' SPACE CHARGE ACTING ON LENGTH: ', scdist,
' CM' 13263 write (16, *)
' POSITION OF S.C. COMPUTATION: ', dcum,
' CM' 13267 call xtypl1(gamref, saphi, aqmoy, dcum)
13270 call xtypl2(gamref, saphi, aqmoy, dcum)
13272 call xtyplp1(gamref, saphi, aqmoy, dcum)
13274 call xtylpk(gamref, saphi, aqmoy, dcum)
13276 call xtypj(gamref, saphi, aqmoy, dcum)
13277 call xtypm(gamref, saphi, aqmoy, dcum)
13308 call xtypl1(gamref, saphi, aqmoy, dcum)
13310 call xtypl2(gamref, saphi, aqmoy, dcum)
13312 call xtyplp1(gamref, saphi, aqmoy, dcum)
13314 call xtylpk(gamref, saphi, aqmoy, dcum)
13316 call xtypj(gamref, saphi, aqmoy, dcum)
13317 call xtypm(gamref, saphi, aqmoy, dcum)
13330 fs(js, is) = f(js, is)
13334 call boucle(ipas, gamref, saphi, dcum, delphr)
13348 if (iscsp==3)
call scheff1(1)
13350 write (16, *)
'Checking for lost particles' 13381 implicit real *8(a-h, o-z)
13382 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
13383 common /faisc/f(10, iptsz), imax, ngood
13384 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
13394 if (f(9,i)==charm(n)) nbch(n) = nbch(n) + 1
13397 itot = itot + nbch(n)
13398 if (itot>=ngood)
go to 110
13401 if (f(9,i)==charm(j))
go to 120
13403 if (f(9,i)/=charm(n))
then 13415 if (f(9,j)==charm(i)) cgtdv(i) = cgtdv(i) + f(6, j)
13417 cgtdv(i) = cgtdv(i)/float(nbch(i))
13428 subroutine boucle(ipas, gamref, saphi, dcum, delphr)
13429 implicit real *8(a-h, o-z)
13430 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
13432 common /midgap/enmil, vapmi
13433 common /azmtch/dlg, xmcph, xmce
13434 common /azlist/icont, iprin
13435 common /itvole/itvol, imamin
13436 common /iter1/dxdki, dphii, phi, dkmske, dkmsphi, retph, xkmi, xkm, dxk00, tke, t1ke, ske, s1ke, phiwc, xk1i, &
13438 common /tranrs/sa11, sa12, sa21, sa22, sact11, sact12, sact21, sact22
13439 common /func/a(200), ylg, atte, ncel, nharm
13442 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
13443 common /ttfcb/t3k, t4k, s3k, s4k
13444 common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
13445 common /jacob/gaks, gaps
13446 common /typl1/yh1k0, yh1k1, yp1k1, yp1k2, yh1k00, yh1k01, yp1k01, yp1k02, yh10, yh11, yp11, yp12
13447 common /typl2/yh2k0, yh2k1, yp2k1, yp2k2, yh2k00, yh2k01, yp2k01, yp2k02, yh20, yh21, yp21, yp22
13448 common /typi1/ye1k0, ye1k1, ye1k2, ye1kc0, ye1kc1, ye1kc2, ye10, ye11, ye12
13449 common /typi2/ye2k0, ye2k1, ye2k2, ye2kc0, ye2kc1, ye2kc2, ye20, ye21, ye22
13450 common /thad2/h0aki, h0akim, h0akm, h0bki, h0bkim, h0bkm, h1aki, h1akim, h1akm, h1bki, h1bkim, h1bkm
13452 common /typlp1/yh1p1, yh2p1, hapi, hbpi
13454 common /typlp2/happi, hbppi
13456 common /typlpk/yh10pk, yh11pk, yh20pk, yh21pk
13459 common /typj/yfsk0, yfsk1, yfsk2, yfsp0, yfsp1, yfsp2, yfskc0, yfskc1, yfskc2, yfsck0, yfsck1, yfsck2, yfscp0, &
13460 yfscp1, yfscp2, yfs0, yfs1, yfs2
13463 common /typm/ynsk0, ynsk1, ynsk2, ynsp0, ynsp1, ynsp2, ynsk0c, ynsk1c, ynsk2c, yns0, yns1, yns2
13464 common /faisc/f(10, iptsz), imax, ngood
13465 common /beamsa/fs(7, iptsz)
13466 common /cdek/dwp(iptsz)
13467 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
13468 common /consta/vl, pi, xmat, rpel, qst
13469 common /dyn/tref, vref
13470 common /fene/wdisp, wphas, wx, wy, rlim, ifw
13471 common /tapes/in, ifile, meta
13473 common /tcav/sv1p(iptsz), sv2p(iptsz), sxv1p(iptsz), sxv2p(iptsz), dwcis(iptsz), beini1(iptsz), phip(iptsz), &
13474 teglp(iptsz), dxdpip(iptsz), dxdkip(iptsz), dxdptp(iptsz), dxk00p(iptsz), dphiip(iptsz), sauphcs(iptsz)
13475 common /iterco/yh11t, yh1k1t, yh1k01t, yh10pkt, yh11pkt, yh1p1t, h1akit, h1akimt, h1akmt, hapit, happit
13476 common /itersi/yh21t, yh2k1t, yh2k01t, yh2p1t, yh20pkt, yh21pkt, h1bkit, h1bkimt, h1bkmt, hbpit, hbppit
13477 common /appel/irstay, ilost, iavp, ispcel
13478 common /etcom/cog(8), exten(17), fd(iptsz)
13479 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
13480 common /tofev/ttvols
13481 common /aerp/vphase, vfield, ierpf
13487 logical itvol, imamin, ispcel
13488 logical iesp, iavp, ichaes, irstay
13493 beref = sqrt(1.-1./(gamref*gamref))
13498 gcog = gcog + f(7, i)/xmat
13499 tcog = tcog + f(6, i)
13501 tcog = tcog/float(ngood)
13502 gcog = gcog/float(ngood)
13503 bcog = sqrt(1.-1./(gcog*gcog))
13504 wcg = (gcog-1.)*xmat
13509 if (ifw==0) dispr = gcog*gcog*wdisp/(gcog*(gcog+1.))
13510 if (ifw==1) dispr = gcog*gcog*wdisp/(gcog*(gcog+1.)*wcg)
13513 write (16, *)
'******************************************' 13514 write (16, *)
'*** FOLLOWED PARTICLE NUMBER: ', i
13515 if (ipas==1)
write (16, *)
' AT SPACE CHARGE POSITION' 13516 if (ipas==2)
write (16, *)
' AT OUTPUT ' 13517 write (16, *)
'******************************************' 13520 gini = f(7, i)/xmat
13521 beini = sqrt(1.-1./(gini*gini))
13522 fd(i) = (gini*beini)/(gcog*bcog)
13525 if (f(9,i)==charm(istc)) f6i = f(6, i) - cgtdv(istc)
13528 if (fh*abs(f6i)>=wphas) f(8, i) = 0.
13529 if (abs(fd(i)-1.)>=dispr) f(8, i) = 0.
13531 radiu = sqrt(f(2,i)*f(2,i)+f(4,i)*f(4,i))
13532 if (radiu>=rlim) f(8, i) = 0.
13533 if (abs(f(2,i))>wx) f(8, i) = 0.
13534 if (abs(f(4,i))>wy) f(8, i) = 0.
13535 if (f(8,i)==0)
then 13536 write (16, 3928) i, int(f(1,i)), f(2, i), f(3, i), f(4, i), f(5, i), f6i*fh*180./pi, f(7, i) - xmat, &
13538 3928
format (
' # ', i5, 1x, i5, 1x, 6(f10.2,1x), 1x, i2)
13540 if (ilost>=ngood) stop
13546 write (16, 558) f(2, i), f(3, i), f(4, i), f(5, i)
13547 558
format (1x,
'* INPUT OF THE ELEMENT: ', /, 1x,
'* X :', e12.5,
' CM XP :', e12.5,
' MRD', /, 1x,
'* Y :', &
13548 e12.5,
' CM YP: ', e12.5,
' MRD', /, 1x,
'*')
13549 f6dg = fh*f(6, i)*180./pi
13550 write (16, *)
' Tof(deg): ', f6dg,
' ENER(MeV) ', f(7, i) - xmat
13552 radiu = sqrt(f(2,i)*f(2,i)+f(4,i)*f(4,i))
13553 if (radiu<1.e-06)
then 13554 dradiu = .001*sqrt(f(3,i)*f(3,i)+f(5,i)*f(5,i))
13556 dradiu = f(3, i)*.001*f(2, i)/radiu + f(4, i)*f(5, i)*.001/radiu
13560 retph = fh*(f(6,i)-tref)
13563 vphasi = vphase*pi/180.
13565 if (ierpf==1) retph = retph + vphasi
13569 call rlux(vecx, len)
13570 r1 = (2.*vecx(1)-1.)*vphasi
13574 phi = saphi + retph
13575 if (i==icont)
write (16, *)
'* PHASE DELAY RELATIVE TO REFERENCE ', retph*180./pi,
' DEG' 13581 t1kc = t1k*cort + t1k
13582 t2kc = t2k*cort + t2k
13583 t3kc = t3k*cort + t3k
13584 t4kc = t4k*cort + t4k
13586 s1kc = s1k*cort + s1k
13587 s2kc = s2k*cort + s2k
13588 s3kc = s3k*cort + s3k
13589 s4kc = s4k*cort + s4k
13596 dxki0 = fh0*(1./beini-1./beref)
13598 tke = tkc + dxdte*t1kc + dxdte*dxdte*t2kc/2. + dxdte**3*t3kc/6. + dxdte**4*t4kc/24.
13599 ske = skc + dxdte*s1kc + dxdte*dxdte*s2kc/2. + dxdte**3*s3kc/6. + dxdte**4*s4kc/24.
13607 tke = tke*(1.+vfield)
13608 ske = ske*(1.+vfield)
13612 call rlux(vecx, len)
13613 r1 = (2.*vecx(1)-1.)*vfield
13618 phiwc = phi + pavph
13622 ddwp = abs(f(9,i))*(tke*cos(phiwc)-ske*sin(phiwc))
13623 enpmt = f(7, i) + ddwp
13625 if (gamps<=1.) f(8, i) = 0.
13626 if (f(8,i)==0.)
then 13628 if (ilost>=ngood) stop
13631 betps = sqrt(1.-1./(gamps*gamps))
13634 xkmi = xk2ii + (xk2ii-xk1ii)*asdl/eqvl + delphr/eqvl
13635 xk1i = xk1ii - xkmi
13636 xk2i = xk2ii - xkmi
13640 dphii = (xk1ii-xk2ii)*eqvl/10. + (xkp1+xkp2)/120.*eqvl**2 + xk1i*asdl
13643 tke = tkc + dxdki*t1kc + dxdki*dxdki*t2kc/2. + dxdki**3*t3kc/6. + dxdki**4*t4kc/24.
13644 t1ke = t1kc + dxdki*t2kc + dxdki*dxdki*t3kc/2. + dxdki**3*t4kc/6.
13645 ske = skc + dxdki*s1kc + dxdki*dxdki*s2kc/2. + dxdki**3*s3kc/6. + dxdki**4*s4kc/24.
13646 s1ke = s1kc + dxdki*s2kc + dxdki*dxdki*s3kc/2. + dxdki**3*s4kc/6.
13655 tke = tke*(1.+vfield)
13656 ske = ske*(1.+vfield)
13657 t1ke = t1ke*(1.+vfield)
13658 s1ke = s1ke*(1.+vfield)
13662 call rlux(vecx, len)
13663 r1 = (2.*vecx(1)-1.)*vfield
13666 t1ke = t1ke*(1.+r1)
13667 s1ke = s1ke*(1.+r1)
13682 phiwc = phi + dphii
13685 dwci = abs(f(9,i))*(tke*cos(phiwc)-ske*sin(phiwc))
13686 enrc = f(7, i) + dwci
13688 becr = sqrt(1.-1./(gacr*gacr))
13690 cxlg = abs(f(9,i))/(4.*xmat*eqvl)
13691 dxdpi = retph - dphci0
13694 dxdpt = dxdpi + dxk00*(1.-dkmske)*asdl - dxdpi*dkmsphi*asdl
13695 dxk00 = fh0*(1./beini-1./beref)
13696 xlh11 = (yh11t+dxk00*(dkmske*yh1k1t+yh1k01t))*cos(dxdpt)
13697 xlh11 = xlh11 + dxdpi*yh1p1t*cos(dxdpt)
13699 xlh112 = dxk00*dxk00*(h1akit+h1akimt*dkmske+h1akmt*dkmske*dkmske)*cos(dxdpt)
13700 xlh112 = xlh112 + dxdpi*dxdpi*hapit*cos(dxdpt)
13701 xlh112 = xlh112 + dxdpi*dxk00*(yh10pkt+dkmske*yh11pkt)*cos(dxdpt)
13703 xlh113 = (dxdpi**3)/3.*happit*cos(dxdpt)
13704 xlh11 = xlh11 + xlh112 + xlh113
13706 xlh21 = (yh21t+dxk00*(dkmske*yh2k1t+yh2k01t))*sin(dxdpt)
13707 xlh21 = xlh21 + dxdpi*yh2p1t*sin(dxdpt)
13709 xlh212 = dxk00*dxk00*(h1bkit+h1bkimt*dkmske+h1bkmt*dkmske**2)*sin(dxdpt)
13710 xlh212 = xlh212 + dxdpi*dxdpi*hbpit*sin(dxdpt)
13711 xlh212 = xlh212 + dxdpi*dxk00*(yh20pkt+dkmske*yh21pkt)*sin(dxdpt)
13713 xlh213 = (dxdpi**3)/3.*hbppit*sin(dxdpt)
13714 xlh21 = xlh21 + xlh212 + xlh213
13715 xlh1i = cxlg*(xlh11-xlh21)
13719 xkmi = xk2ii + sauphc/eqvl + (xk2ii-xk1ii)*asdl/eqvl
13721 xk1i = xk1ii - xkmi
13723 dphii = (xk1ii-xk2ii)*eqvl/10. + (xkp1+xkp2)/120.*eqvl**2 + xk1i*asdl
13727 dts = (tke*t1ke+ske*s1ke)/(tke*tke+ske*ske)
13728 tiltal = -4.*atan(dts*3.2/eqvl)
13729 if (tiltal/=0.)
then 13733 ftil = 1./tan(til2) - 1./til2 - dts*2./xlrei
13734 dftil = -1./(sin(til2)*sin(til2)) + 1./(til2*til2)
13735 if (dftil/=6.*0.)
then 13736 til2 = til2 - ftil/dftil
13737 gx = 1./tan(til2) - 1./til2
13744 tegl1 = phslil*phslil/(sin(phslil/2.)*sin(phslil/2.))
13745 tegl2 = (tke*tke+ske*ske)
13746 tegl = tegl1*tegl2/(eqvl*32.)
13749 phitti = phiwc + xk1i*asdl - phslip/2.
13750 phitsi = phiwc + xk2i*asdl + phslip/2.
13751 cetf1 = f(9, i)*f(9, i)/(16.*xmat*xmat*eqvl*eqvl)
13755 cfv1 = (gini*gini+2.)/((gini*gini-1.)**2)
13756 cfv2 = (gacr*gacr+2.)/((gacr*gacr-1.)**2)
13757 sv1 = cfv1*(tke*cos(phitti)-ske*sin(phitti))**2
13758 sv1 = cetf1*sv1*(phslil/sin(phslil/2.))**2
13759 sv2 = cfv2*(tke*cos(phitsi)-ske*sin(phitsi))**2
13760 sv2 = cetf1*sv2*(phslil/sin(phslil/2.))**2
13762 ceti = fh0*abs(f(9,i))/(4.*xmat*eqvl)
13766 cxv1 = (gini*gini-1.)**1.5
13767 cxv2 = (gacr*gacr-1.)**1.5
13768 sxv1 = (tke*sin(phitti)+ske*cos(phitti))*phslil/sin(phslil/2.)
13769 sxv1 = -ceti*sxv1/cxv1
13770 sxv2 = (tke*sin(phitsi)+ske*cos(phitsi))*phslil/sin(phslil/2.)
13771 sxv2 = -ceti*sxv2/cxv2
13778 sauphcs(i) = sauphc
13792 sauphc = sauphcs(i)
13800 gini = 1./sqrt(1.-beini*beini)
13811 cxlg = abs(f(9,i))/(4.*xmat*eqvl)
13813 xlh11 = (yh11+dxk00*(dkmske*yh1k1+yh1k01))*cos(dxdpt)
13814 xlh11 = xlh11 + dxdpi*yh1p1*cos(dxdpt)
13816 xlh112 = dxk00*dxk00*(h1aki+h1akim*dkmske+h1akm*dkmske*dkmske)*cos(dxdpt)
13817 xlh112 = xlh112 + dxdpi*dxdpi*hapi*cos(dxdpt)
13818 xlh112 = xlh112 + dxdpi*dxk00*(yh10pk+dkmske*yh11pk)*cos(dxdpt)
13820 xlh113 = (dxdpi**3)/3.*happi*cos(dxdpt)
13821 xlh11 = xlh11 + xlh112 + xlh113
13823 xlh21 = (yh21+dxk00*(dkmske*yh2k1+yh2k01))*sin(dxdpt)
13824 xlh21 = xlh21 + dxdpi*yh2p1*sin(dxdpt)
13826 xlh212 = dxk00*dxk00*(h1bki+h1bkim*dkmske+h1bkm*dkmske**2)*sin(dxdpt)
13827 xlh212 = xlh212 + dxdpi*dxdpi*hbpi*sin(dxdpt)
13828 xlh212 = xlh212 + dxdpi*dxk00*(yh20pk+dkmske*yh21pk)*sin(dxdpt)
13830 xlh213 = (dxdpi**3)/3.*hbppi*sin(dxdpt)
13831 xlh21 = xlh21 + xlh212 + xlh213
13832 xlh1i = cxlg*(xlh11-xlh21)
13835 cxlg = abs(f(9,i))/(4.*xmat*eqvl)
13836 xlh01 = (yh10+dxdki*yh1k0+dxk00*yh1k00)*cos(dxdpt)
13837 xlh02 = (yh20+dxdki*yh2k0+dxk00*yh2k00)*sin(dxdpt)
13838 xlh0i = cxlg*(xlh01-xlh02)
13840 xlp11 = (yp11+dxdki*yp1k1+dxk00*yp1k01)*cos(dxdpt)
13841 xlp21 = (yp21+dxdki*yp2k1+dxk00*yp2k01)*sin(dxdpt)
13842 xlp1i = cxlg*(xlp11-xlp21)
13843 xlp12 = (yp12+dxdki*yp1k2+dxk00*yp1k02)*cos(dxdpt)
13844 xlp22 = (yp22+dxdki*yp2k2+dxk00*yp2k02)*sin(dxdpt)
13845 xlp2i = cxlg*(xlp12-xlp22)
13846 radiu = sqrt(f(2,i)*f(2,i)+f(4,i)*f(4,i))
13847 if (radiu<1.e-06)
then 13848 dradiu = .001*sqrt(f(3,i)*f(3,i)+f(5,i)*f(5,i))
13850 dradiu = f(3, i)*.001*f(2, i)/radiu + f(4, i)*f(5, i)*.001/radiu
13855 rrp = rp*sqrt(beini*gini)
13856 rrpp = rpp*sqrt(beini*gini)
13861 phiwc = phi + dphii
13864 gacr =
gamci(phiwc, pcresi, gini, istm, abs(f(9,i)))
13865 dwci = (gacr-gini)*xmat
13867 dwpi = dwci + xmat*fh0*fh0*rrp*rrp/4.*xlh0i + xmat*rrp*rrpp*fh0*fh0/2.*xlh1i
13869 delphi = sauphc + fh0**3*rrp*rrp/4.*xlp1i + fh0**3*rrp*rrpp/2.*xlp2i
13873 f(7, i) = f(7, i) + dwpi + dwp(i)
13874 gamsor = f(7, i)/xmat
13875 if (gamsor<=1.) f(8, i) = 0.
13877 if (f(8,i)==0.)
go to 19
13878 besor = sqrt(1.-1./(gamsor*gamsor))
13880 delgam = dwp(i)/xmat
13881 gamkk0 = f(7, i)/xmat
13882 bekk0 = sqrt(1.-1./(gamkk0*gamkk0))
13883 dbek21 = delgam/(bekk0**3*gamkk0**3)
13884 delsc = fh0*scdist*dbek21/2.
13885 delphi = delphi + delsc
13886 ditemp = ylg/(besor*vl) + delphi/fh
13887 f(6, i) = fs(6, i) + ditemp
13889 f(7, i) = f(7, i) + dwpi
13890 gamsor = f(7, i)/xmat
13891 if (gamsor<=1.) f(8, i) = 0.
13893 if (f(8,i)==0.)
then 13894 f6i = f(6, i) - tcog
13895 write (16, 3928) i, int(f(1,i)), f(2, i), f(3, i), f(4, i), f(5, i), f6i*fh*180./pi, f(7, i) - xmat, &
13897 if (ilost>=ngood) stop
13901 besor = sqrt(1.-1./(gamsor*gamsor))
13902 ditemp = ylg/(besor*vl) + delphi/fh
13903 f(6, i) = f(6, i) + ditemp
13907 f(7, i) = f(7, i) + dwpi
13908 gamsor = f(7, i)/xmat
13909 if (gamsor<=1.) f(8, i) = 0.
13910 if (f(8,i)==0.)
then 13911 write (16, 3928) i, int(f(1,i)), f(2, i), f(3, i), f(4, i), f(5, i), f(6, i)*fh*180./pi, f(7, i) - xmat, &
13913 if (ilost>=ngood) stop
13917 besor = sqrt(1.-1./(gamsor*gamsor))
13920 ditemp = ylg/(2.*besor*vl) + delphi/fh
13925 f(6, i) = f(6, i) + ditemp
13929 write (16, *)
'* DYNAMICS AT THE OUTPUT :' 13930 write (16, 994) delphi*180./pi, delsc*180./pi, dwp(i)
13931 994
format (1x,
'* PHASE JUMP ', e12.5,
' DEG CORRECTED BY :', e12.5,
' DEG ',
' SC KICK(MEV) ', e12.5)
13932 enrprin = f(7, i) - xmat
13933 write (16, 88) dwpi, enrprin, besor, f(9, i), ditemp
13934 88
format (1x,
'* ENERGY GAIN : ', e14.7,
' MEV',
' ENERGY :', e14.7,
' MEV', /, 1x,
'* BETA :', e12.5, /, &
13935 1x,
'* CHARGE :', f5.0,
' TRANSIT TIME :', e12.5,
' SEC', /, 1x,
'*')
13936 write (16, *)
'TK TKE ', tk, tke
13937 write (16, *)
'SK SKE ', sk, ske
13938 write (16, *)
'PCREST PCRESI', pcrest, pcresi
13941 write (16, *)
'* DYNAMICS AT THE POSITION OF SPACE CHARGE :' 13942 enrprin = f(7, i) - xmat
13943 write (16, 9944) delphi*180./pi, dwpi, enrprin, ditemp
13944 9944
format (1x,
'* PHASE JUMP ', e12.5,
' DEG ',
' ENERGY GAIN : ', e14.7,
' MeV',
' ENERGY :', e14.7,
' MEV', &
13945 /,
' TRANSIT TIME :', e12.5,
' SEC', /, 1x,
'*')
13948 amort = sqrt(beini*gini/(besor*gamsor))
13954 cetf = f(9, i)*f(9, i)*sqcttf*sqcttf/(16.*xmat*xmat*eqvl*eqvl)
13958 xjf0i = yfs0 + dxdki*(yfsk0+yfsck0) + dxdpi*(yfsp0+yfscp0) + dxk00*yfskc0
13960 xjf1i = yfs1 + dxk00*dkmske*(yfsk1+yfsck1) + dxdpi*(yfsp1+yfscp1) + dxk00*yfskc1
13962 xjf2i = yfs2 + dxk00*dkmske*(yfsk2+yfsck2) + dxdpi*(yfsp2+yfscp2) + dxk00*yfskc2
13967 cetm = f(9, i)*f(9, i)*tegl/(xmat*xmat)
13971 xmn0i = yns0 + dxdki*ynsk0 + dxdpi*ynsp0 + dxk00*ynsk0c
13973 xmn1i = yns1 + dxk00*dkmske*ynsk1 + dxdpi*ynsp1 + dxk00*ynsk1c
13975 xmn2i = yns2 + dxk00*dkmske*ynsk2 + dxdpi*ynsp2 + dxk00*ynsk2c
13981 ceti = fh0*abs(f(9,i))/(8.*xmat*eqvl)
13985 xie01 = (ye10+dxdki*ye1k0+dxk00*ye1kc0)*cos(dxdpt)
13986 xie02 = (ye20+dxdki*ye2k0+dxk00*ye2kc0)*sin(dxdpt)
13987 xie0i = -ceti*(xie01+xie02)
13988 xie11 = (ye11+dxdki*ye1k1+dxk00*ye1kc1)*cos(dxdpt)
13989 xie12 = (ye21+dxdki*ye2k1+dxk00*ye2kc1)*sin(dxdpt)
13990 xie1i = -ceti*(xie11+xie12)
13991 xie21 = (ye12+dxdki*ye1k2+dxk00*ye1kc2)*cos(dxdpt)
13992 xie22 = (ye22+dxdki*ye2k2+dxk00*ye2kc2)*sin(dxdpt)
13993 xie2i = -ceti*(xie21+xie22)
14003 xq01 = (xq1+asdl*xq0)
14004 xq12 = (xq2+asdl*xq1)
14007 a11 = -xq01*(1.+(v1+v2)*eqvl*eqvl/120.)
14008 a12 = -(xq2+2.*asdl*xq1+asdl*asdl*xq0+eqvl*eqvl*((v1+v2)/120.+eqvl*v2/120.)*xq01)
14009 za = -(xq12/eqvl+v2*eqvl*eqvl*xq01/120.)
14010 zb = -((eqvl+asdl)*xq12/eqvl-eqvl*xq01/10.+v2*(eqvl+asdl)*eqvl*eqvl*xq01/120.)
14011 a21 = xq0*(1.+(v1+v2)*eqvl*eqvl/120.)
14012 a22 = xq1 + xq0*(asdl+asdl*eqvl*eqvl*(v1+v2)/120.+eqvl**3*v2/120.)
14013 zc = xq1/eqvl + v2*eqvl*eqvl*xq0/120.
14014 zd = (asdl+eqvl)*xq1/eqvl - (eqvl/10.+v2*(eqvl+asdl)*eqvl*eqvl/120.)*xq0
14016 tma = 1./(1.-za-zc*zb/(1.-zd))
14017 t11 = (a11+zb*a21/(1.-zd))*tma
14018 t12 = (a12+zb*a22/(1.-zd))*tma
14019 t21 = (a21+zc*t11)/(1.-zd)
14020 t22 = (a22+zc*t12)/(1.-zd)
14021 vr11 = (1.+t11+dcum*t21)
14022 vr12 = (t12+dcum*(1.+t22))
14026 detre = vr11*vr22 - vr12*vr21
14027 write (16, 8921) vr11, vr12, vr21, vr22, detre
14028 8921
format (2x,
' TRANSVERSE CANONICAL MATRIX:(cm,radian) ', /, 2x,
' VR11:', e12.5,
' VR12:', e12.5, /, 2x, &
14029 ' VR21:', e12.5,
' VR22:', e12.5, /, 2x,
' DETERMINANT :', e12.5, //)
14067 fxt1 = a11*f(2, i) + a12*f(3, i)*1.e-03
14068 fxt2 = a21*f(2, i) + a22*f(3, i)*1.e-03
14069 fxt3 = a11*f(4, i) + a12*f(5, i)*1.e-03
14070 fxt4 = a21*f(4, i) + a22*f(5, i)*1.e-03
14072 f(3, i) = fxt2*1.e03
14074 f(5, i) = fxt4*1.e03
14077 stta11 = vr11*sact11 + vr12*sact21
14078 stta12 = vr11*sact12 + vr12*sact22
14079 stta21 = vr21*sact11 + vr22*sact21
14080 stta22 = vr21*sact12 + vr22*sact22
14085 saa11 = sact11*amort
14086 saa12 = sact12*amort
14087 saa21 = sact21*amort
14088 saa22 = sact22*amort
14089 det = a11*a22 - a12*a21
14090 write (16, 992) a11, a12*1.e-3, a21*1.e3, a22, det, amort
14091 992
format (1x,
'* TRANSVERSE MATRIX (cm,mrd)', /, 1x,
'*', e12.5, 3x, e12.5, /, 1x,
'*', e12.5, 3x, e12.5, /, &
14092 1x,
'* DETERMINANT :', e12.5,
' DUMPING OF ENERGY :', e12.5)
14094 write (16, 559) f(2, i), f(3, i), f(4, i), f(5, i)
14095 559
format (
' * TRANVERSE COORDINATES AT OUTPUT ', /, 1x,
'* X :', e12.5,
' CM XP :', e12.5,
' MRD ', /, 1x, &
14096 '* Y :', e12.5,
' CM YP :', e12.5,
' MRD')
14097 if (ipas==2)
write (16, *)
'********** END OF FOLLOWED PARTICLE ********' 14107 subroutine bunparm(v, dp, harm, prlim)
14108 implicit real *8(a-h, o-z)
14109 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
14111 common /consta/vl, pi, xmat, rpel, qst
14112 common /dyn/tref, vref
14113 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
14114 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
14115 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
14116 common /faisc/f(10, iptsz), imax, ngood
14117 common /etcom/cog(8), exten(17), fd(iptsz)
14118 common /fene/wdisp, wphas, wx, wy, rlim, ifw
14119 common /corec/tref1
14120 common /qmoyen/qmoy
14121 common /aerp/vphase, vfield, ierpf
14122 common /itvole/itvol, imamin
14123 common /compt/nrres, nrtre, nrbunc, nrdbun
14124 common /shif/dtiph, shift
14125 common /tofev/ttvols
14126 common /fcont/ifcont
14130 logical chasit, itvol, imamin, shift
14132 call stapl(davtot*10.)
14139 nrbunc = nrbunc + 1
14141 write (6, 8254) nrtre, nrbunc, cr
14142 8254
format (
'Transport element:', i5,
' Buncher :', i5, a1, $)
14143 if (harm<=0.) harm = 1.
14152 tcog = tcog + f(6, np)
14153 gpa = f(7, np)/xmat
14154 bcog = sqrt(1.-1./(gpa*gpa)) + bcog
14156 tcog = tcog/float(ngood)
14157 bcog = bcog/float(ngood)
14158 gcog = 1./sqrt(1.-bcog*bcog)
14159 encog = xmat*gcog - xmat
14163 ttvpi = harm*ttvols*fcpi
14166 xkpi = (xkpi-float(ixkpi))*360.
14167 write (16, *)
' *** TOF correction:', -xkpi,
' deg' 14168 dp = dp - xkpi*pi/180.
14169 write (16, *)
' ***phase of RF adjusted : ', dp*180./pi,
' deg' 14186 dav1(idav, 2) = dp*180./pi
14187 dav1(idav, 3) = prlim
14188 dav1(idav, 4) = davtot*10.
14189 if (itvol) dav1(idav, 5) = -xkpi
14192 178
format (/,
' Dynamics at the input', /, 5x,
' BETA GAMMA ENERGY(MeV) ',
' TOF(deg) TOF(sec)')
14193 write (16, 1788) bcog, gcog, encog, tcog*fcpi, tcog
14194 1788
format (
' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
14195 e0t = harm*v/(bcog*wavel)
14199 if (ierpf==1) e0t = e0t*(1.+vfield)
14203 call rlux(vecx, len)
14204 r1 = (2.*vecx(1)-1.)*vfield
14208 cay = harm*twopi/(bcog*gcog*wavel)
14210 con = twopi*e0t*qmoy/xmat
14213 if (ierpf==1) dp = dp + vphase*rad
14217 call rlux(vecx, len)
14218 r1 = (2.*vecx(1)-1.)*vphase*rad
14229 gamref = 1./sqrt(1.-beref*beref)
14230 older = xmat*gamref
14236 gamref = 1./sqrt(1.-beref*beref)
14237 older = xmat*gamref
14240 dgr = v*cos(harm*ttvols*fh+dp)*qmoy
14243 vref = vl*sqrt(1.-1./(gor*gor))
14244 enrprin = older - xmat
14245 write (16, 165) beref, gamref, enrprin, tref*fh*180./pi, tref
14246 165
format (
' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
14251 rs = f(2, np)**2 + f(4, np)**2
14252 a = harm*(f(6,np)-tref+ttvols)*fh + dp
14256 w = f(7, np) - xmat
14257 bg = sqrt(w/xmat*(2.+w/xmat))
14261 f3 = f(3, np)*1.e-03
14262 f5 = f(5, np)*1.e-03
14267 xi0 = 1. + arg*(1.+arg*(.25+arg/36.))
14269 dw = v*cos(a)*xi0*f(9, np)
14272 bgav = sqrt(wb/xmat*(2.+wb/xmat))
14275 bcour = bcour + bav
14277 bgf = sqrt(wf/xmat*(2.+wf/xmat))
14278 xi1okr = .5 + .25*arg + arg**2/24.
14279 del = -con*s*(1.-bav*bcog)*xi1okr/bav
14280 tcog = tcog + f(6, np)
14281 f3 = (bgx+del*f2)/bgf
14282 f(3, np) = f3*1.e03
14283 f5 = (bgy+del*f4)/bgf
14284 f(5, np) = f5*1.e03
14285 f(7, np) = wf + xmat
14288 wsync = wsync/float(ngood)
14289 bcour = bcour/float(ngood)
14290 tcog = tcog/float(ngood)
14297 engain = wsync - encog
14300 gamref = 1./sqrt(1.-beref*beref)
14301 enref = ewer - xmat
14309 if (itvol) ttvols = tref
14311 3777
format (/,
' Dynamics at the output', /, 5x,
' BETA dW(MeV) ENERGY(MeV) ',
' TOF(deg) TOF(sec)')
14312 write (16, 3473) beref, dgr, enref, fh*tref*180./pi, tref
14313 3473
format (
' REF ', f7.5, 3x, f10.6, 3x, f8.3, 3x, e12.5, 3x, e12.5)
14314 write (16, 1789) bcour, engain, wsync, tcog*fh*180./pi, tcog
14315 1789
format (
' COG ', f7.5, 3x, f10.6, 3x, f8.3, 3x, e12.5, 3x, e12.5)
14317 dav1(idav, 36) = ngood
14320 write (16, *)
'After buncher, bunched beam assumed' 14343 implicit real *8(a-h, o-z)
14344 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
14345 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
14346 common /dyn/tref, vref
14347 common /faisc/f(10, iptsz), imax, ngood
14348 common /qmoyen/qmoy
14349 common /consta/vl, pi, xmat, rpel, qst
14350 common /newref/dephas, dewref, iref, irefw
14351 common /tapes/in, ifile, meta
14352 common /itvole/itvol, imamin
14353 common /tofev/ttvols
14354 logical itvol, imamin
14361 gnref = wnref/xmat + 1.
14362 bref = sqrt(gnref*gnref-1.)/gnref
14364 delt = dephas*pi/(fh*180.)
14368 if (itvol) ttvols = tref
14373 gref = 1./sqrt(1-bref*bref)
14374 dbref = bref*dewref/(gref*(gref+1.))
14376 delt = dephas*pi/(fh*180.)
14379 vref = vref + dbref*vl
14380 if (itvol) ttvols = tref
14384 gref = 1./sqrt(1.-bref*bref)
14385 wref = (gref-1.)*xmat
14386 wnref = wref + dewref
14387 gnref = wnref/xmat + 1.
14388 bref = sqrt(gnref*gnref-1.)/gnref
14390 delt = dephas*pi/(fh*180.)
14394 if (itvol) ttvols = tref
14402 tcog = tcog + f(6, i)
14403 gpai = f(7, i)/xmat
14404 bcog = bcog + sqrt(1.-1./(gpai*gpai))
14406 tcog = tcog/float(ngood)
14407 bcog = bcog/float(ngood)
14408 gcog = 1./sqrt(1-bcog*bcog)
14409 wcog = (gcog-1.)*xmat
14411 delt = dephas*pi/(fh*180.)
14413 wrefn = wcog + wcog*dewref/100.
14417 grefn = wrefn/xmat + 1.
14418 vref = vl*sqrt(grefn*grefn-1.)/grefn
14419 if (itvol) ttvols = tref
14422 wncog = wcog + dewref
14423 gncog = wncog/xmat + 1.
14424 bcog = sqrt(gncog*gncog-1.)/gncog
14428 if (itvol) ttvols = tref
14432 garef = 1./sqrt(1.-baref*baref)
14433 waref = (garef-1.)*xmat
14435 gnref = 1./sqrt(1.-bnref*bnref)
14436 wnref = (gnref-1.)*xmat
14438 write (16, 20) atref*fcpi, attvols*fcpi, waref
14439 20
format (3x,
'**before NREF', /, 5x,
'tof of the reference: ', e12.5,
' deg tof for adjustments: ', e12.5, &
14440 ' deg energy of reference: ', e12.5,
' MeV')
14441 write (16, 21) tref*fcpi, ttvols*fcpi, wnref
14442 21
format (3x,
'**after NREF', /, 5x,
'tof of the reference: ', e12.5,
' deg tof for adjustments: ', e12.5, &
14443 ' deg energy of reference: ', e12.5,
' MeV')
14445 end subroutine refer 14465 subroutine steer(fld, nvf)
14466 implicit real *8(a-h, o-z)
14468 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
14469 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
14470 common /dyn/tref, vref
14471 common /consta/vl, pi, xmat, rpel, qst
14473 common /faisc/f(10, iptsz), imax, ngood
14474 common /etcom/cog(8), exten(17), fd(iptsz)
14475 common /qmoyen/qmoy
14477 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
14478 common /tapes/in, ifile, meta
14479 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
14480 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
14481 common /compt/nrres, nrtre, nrbunc, nrdbun
14483 logical iesp, ichaes
14487 write (6, 8254) nrtre, nrres, cr
14488 8254
format (
'Transport element:', i5,
' Accelerating element:', i5, a1, $)
14491 write (16, *)
'Horizontal magnetic steerer: ', fld,
' Tm' 14493 const = xmat*1.e8/(f(9,i)*vl)
14494 gpai = f(7, i)/xmat
14495 bpai = sqrt(1.-1./(gpai*gpai))
14496 dispx = fld/(const*gpai*bpai)*1000.
14497 f(3, i) = f(3, i) + dispx
14499 else if (nvf==1)
then 14501 write (16, *)
'Vertical magnetic steerer: ', fld,
' Tm' 14503 const = xmat*1.e8/(f(9,i)*vl)
14504 gpai = f(7, i)/xmat
14505 bpai = sqrt(1.-1./(gpai*gpai))
14506 dispy = fld/(const*gpai*bpai)*1000.
14507 f(5, i) = f(5, i) + dispy
14509 else if (nvf==2)
then 14511 write (16, *)
'Horizontal electrostatic steerer: ', fld,
' kV*m/m' 14513 gpai = f(7, i)/xmat
14514 const = (gpai/(gpai*gpai-1.))*f(9, i)
14515 dispx = const*fld/xmat
14516 f(3, i) = f(3, i) + dispx
14518 else if (nvf==3)
then 14520 write (16, *)
'Vertical electrostatic steerer: ', fld,
' kV*m/m' 14522 gpai = f(7, i)/xmat
14523 const = (gpai*gpai/(gpai*gpai-1.))*f(9, i)
14524 dispy = const*fld/xmat
14525 f(5, i) = f(5, i) + dispy
14529 write (16, *)
'Wrong value for NVF in STEERER' 14533 end subroutine steer 14563 implicit real *8(a-h, o-z)
14564 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
14565 common /etchas/fractx, fracty, fractl
14566 common /dyn/tref, vref
14567 common /faisc/f(10, iptsz), imax, ngood
14568 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
14569 common /davprt/shortl
14570 common /qmoyen/qmoy
14571 common /etcom/cog(8), exten(17), fd(iptsz)
14572 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
14573 common /etcha3/ichxyz(iptsz)
14574 common /speda/dave, idave
14575 common /cptemit/xltot(maxcell1), nbemit
14576 common /consta/vl, pi, xmat, rpel, qst
14577 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
14578 common /mcs/imcs, ncstat, cstat(20)
14579 common /strip/atm, qs, atms, ths, qop, sqst(6), anp, nqst
14580 common /shortl/davprt
14581 logical dave, chasit
14582 dimension foo(20, 9), ndp(20)
14583 character *80 davprt(maxcell1), shortl
14585 nbemit = nbemit + 1
14589 xltot(nbemit) = davtot
14592 dav1(idav, 40) = fh
14597 if (l==1) davprt(idav) = shortl
14601 bcog = sqrt(1.-1./(gcog*gcog))
14606 qdisp = 2.*sqrt(exten(1))
14607 qmdv = exten(1)*exten(3) - exten(2)*exten(2)
14608 sqmdv = 4.*pi*sqrt(qmdv)
14610 qdp = 2.*sqrt(exten(3))
14612 cor12 = exten(2)/sqrt(exten(1)*exten(3))
14621 gref = 1./sqrt(1.-beref*beref)
14622 dav1(idav, 3) = beref
14623 dav1(idav, 4) = xmat*(gref-1.)
14624 dav1(idav, 5) = -(int(tref*fh/pi+0.5)-tref*fh/pi)*180.
14626 dav1(idav, 5) = (tref*fh/pi)*180.
14630 phnw = -(int(tcog*fh/pi+0.5)-tcog*fh/pi)*180.
14632 phnw = (tcog*fh/pi)*180.
14633 dav1(idav, 6) = encog - xmat
14634 dav1(idav, 7) = phnw
14638 dav1(idav, 8) = encog - xmat - dav1(idav, 4)
14639 dav1(idav, 9) = phnw - dav1(idav, 5)
14645 dav1(idav, 10) = qdp*180./pi
14646 dav1(idav, 11) = qdisp
14647 dav1(idav, 12) = sqmdv/pi
14648 dav1(idav, 23) = cor12
14653 trqtx = exten(4)*exten(5) - exten(8)*exten(8)
14654 trqpy = exten(6)*exten(7) - exten(9)*exten(9)
14655 surxth = 4.*pi*sqrt(trqtx)
14656 suryph = 4.*pi*sqrt(trqpy)
14657 qditax = 2.*sqrt(exten(4))
14658 qdiant = 2.*sqrt(exten(5))
14659 qditay = 2.*sqrt(exten(6))
14660 qdianp = 2.*sqrt(exten(7))
14664 dav1(idav, 13) = qditax*10.
14665 dav1(idav, 14) = qdiant
14666 dav1(idav, 15) = 0.
14667 if (exten(4)/=0. .and. exten(5)/=0.) dav1(idav, 15) = exten(8)/sqrt(exten(4)*exten(5))
14669 dav1(idav, 16) = bcog*surxth*10./(pi*sqrt(1.-bcog*bcog))
14671 dav1(idav, 17) = surxth*10./pi
14675 dav1(idav, 20) = 0.
14676 if (exten(6)/=0. .and. exten(7)/=0.) dav1(idav, 20) = exten(9)/sqrt(exten(6)*exten(7))
14677 dav1(idav, 18) = qditay*10.
14678 dav1(idav, 19) = qdianp
14680 dav1(idav, 21) = bcog*suryph*10./(pi*sqrt(1.-bcog*bcog))
14682 dav1(idav, 22) = suryph*10./pi
14683 dav1(idav, 30) = float(ngood)
14684 dav1(idav, 31) = cog(4)*10.
14685 dav1(idav, 32) = cog(5)
14686 dav1(idav, 33) = cog(6)*10.
14687 dav1(idav, 34) = cog(7)
14689 dav1(idav, 26) = 0.
14692 dav2(idav, 31) = fractx
14693 dav2(idav, 32) = fracty
14694 dav2(idav, 33) = fractl
14698 ichxyz(i) = ichas(i)
14704 bcog = sqrt(1.-1./(gcog*gcog))
14705 enprt = encog - xmat
14709 qdisp = 2.*sqrt(exten(1))
14710 qmdv = exten(1)*exten(3) - exten(2)*exten(2)
14711 sqmdv = 4.*pi*sqrt(qmdv)
14713 qdp = 2.*sqrt(exten(3))
14715 cor12 = exten(2)/sqrt(exten(1)*exten(3))
14724 gref = 1./sqrt(1.-beref*beref)
14725 dav2(idav, 3) = beref
14726 dav2(idav, 4) = xmat*(gref-1.)
14727 dav2(idav, 5) = (int(tref*fh/pi+0.5)-tref*fh/pi)*180.
14731 phnw = -(int(tcog*fh/pi+0.5)-tcog*fh/pi)*180.
14732 dav2(idav, 6) = encog - xmat
14733 dav2(idav, 7) = phnw
14737 dav2(idav, 8) = encog - xmat - dav2(idav, 4)
14738 dav2(idav, 9) = phnw - dav2(idav, 5)
14744 dav2(idav, 10) = qdp*180./pi
14745 dav2(idav, 11) = qdisp
14746 dav2(idav, 12) = sqmdv/pi
14747 dav2(idav, 23) = cor12
14754 ichxyz(i) = ichas(i)*ichxyz(i)
14760 bcog = sqrt(1.-1/(gcog*gcog))
14761 dav2(idav, 26) = cog(4)*10.
14762 dav2(idav, 27) = cog(5)
14764 trqty = exten(4)*exten(5) - exten(8)*exten(8)
14765 surxth = 4.*pi*sqrt(trqty)
14766 qditax = 2.*sqrt(exten(4))
14767 qdiant = 2.*sqrt(exten(5))
14773 dav2(idav, 13) = qditax*10.
14774 dav2(idav, 14) = qdiant
14775 dav2(idav, 15) = 0.
14776 if (exten(4)/=0. .and. exten(5)/=0.) dav1(idav, 15) = exten(8)/sqrt(exten(4)*exten(5))
14778 dav2(idav, 16) = bcog*surxth*10./(pi*sqrt(1.-bcog*bcog))
14780 dav2(idav, 17) = surxth*10./pi
14785 ichxyz(i) = ichas(i)*ichxyz(i)
14791 bcog = sqrt(1.-1./(gcog*gcog))
14792 dav2(idav, 28) = cog(6)*10.
14793 dav2(idav, 29) = cog(7)
14795 trqpz = exten(6)*exten(7) - exten(9)*exten(9)
14796 suryph = 4.*pi*sqrt(trqpz)
14797 qditay = 2.*sqrt(exten(6))
14798 qdianp = 2.*sqrt(exten(7))
14802 dav2(idav, 20) = 0.
14803 if (exten(6)/=0. .and. exten(7)/=0.) dav2(idav, 20) = exten(9)/sqrt(exten(6)*exten(7))
14804 dav2(idav, 18) = qditay*10.
14805 dav2(idav, 19) = qdianp
14807 dav2(idav, 21) = bcog*suryph*10./(pi*sqrt(1.-bcog*bcog))
14809 dav2(idav, 22) = suryph*10./pi
14811 dav1(idav, 26) = 1.
14818 write (16,
'(1x,a4)')
'EMIT' 14826 if (f(8,i)==1)
then 14828 if (f(9,i)==cstat(k))
then 14829 ndp(k) = ndp(k) + 1
14831 foo(k, j) = foo(k, j) + f(j, i)
14838 if (ndp(k)/=0)
then 14840 foo(k, j) = foo(k, j)/float(ndp(k))
14844 write (16, *)
' Q Particles beta Wcog(MeV)', &
14845 ' Wcog(MeV/u) Pcog(kG.cm) TOF(deg) TOF(sec) ',
' X_avg(cm) Xp_avg(mrad) ', &
14846 'Y_avg(cm) Yp_avg(mrad)' 14848 if (ndp(k)/=0)
then 14849 gref = foo(k, 7)/xmat
14850 bref = sqrt(1.-1./(gref*gref))
14851 xe = (gref-1.)*xmat
14853 bor = 3.3356*xmat*bref*gref/cstat(k)
14854 write (16,
'(2x,f5.2,3x,I5,5x,F9.7, 5(1x,E12.5),1x,4(F12.5,2x))') cstat(k), &
14855 ndp(k), bref, xe, xe/atm, bor, foo(k, 6)*180.*fh/pi, foo(k, 6), foo(k, 2), foo(k, 3), foo(k, 4), foo(k, 5)
14857 write (16,
'(2x,f5.2,3x,I5)') cstat(k), ndp(k)
14869 implicit real *8(a-h, o-z)
14870 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
14871 common /dyn/tref, vref
14872 common /faisc/f(10, iptsz), imax, ngood
14873 common /qmoyen/qmoy
14874 common /etcom/cog(8), exten(17), fd(iptsz)
14875 common /consta/vl, pi, xmat, rpel, qst
14876 common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
14877 common /trace3e/tracebi(6), traceei(3)
14878 character *128 trace3h, trace3t, tif
14885 qdisp = 2.*sqrt(exten(1))
14886 qmdv = exten(1)*exten(3) - exten(2)*exten(2)
14887 sqmdv = 4.*pi*sqrt(qmdv)
14889 qdp = 2.*sqrt(exten(3))
14891 cor12 = exten(2)/sqrt(exten(1)*exten(3))
14893 trqtx = exten(4)*exten(5) - exten(8)*exten(8)
14894 trqpy = exten(6)*exten(7) - exten(9)*exten(9)
14895 surxth = 4.*pi*sqrt(trqtx)
14896 suryph = 4.*pi*sqrt(trqpy)
14897 qditax = 2.*sqrt(exten(4))
14898 qdiant = 2.*sqrt(exten(5))
14899 qditay = 2.*sqrt(exten(6))
14900 qdianp = 2.*sqrt(exten(7))
14903 emitx = surxth*10./pi
14905 if (exten(4)/=0. .and. exten(5)/=0.) sgn = exten(8)/sqrt(exten(4)*exten(5))
14906 betax = qditax*10.*qditax*10./emitx
14907 gamx = qdiant*qdiant/emitx
14908 alphax = sqrt(betax*gamx-1.)
14909 if (sgn>0.) alphax = -alphax
14911 emity = suryph*10./pi
14913 if (exten(6)/=0. .and. exten(7)/=0.) sgn = exten(9)/sqrt(exten(6)*exten(7))
14914 betay = qditay*10.*qditay*10./emity
14915 gamy = qdianp*qdianp/emity
14916 alphay = sqrt(betay*gamy-1.)
14917 if (sgn>0.) alphay = -alphay
14919 emitz = sqmdv/pi*1000.*(180./pi)
14920 betaz = qdp*180./pi*qdp*180./pi/emitz
14921 gamz = qdisp*1000.*qdisp*1000./emitz
14922 alphaz = sqrt(betaz*gamz-1.)
14923 if (cor12>0.) alphaz = -alphaz
14925 tracebi(1) = alphax
14927 tracebi(3) = alphay
14929 tracebi(5) = alphaz
14951 implicit real *8(a-h, o-z)
14952 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
14953 common /dyn/tref, vref
14954 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
14955 common /faisc/f(10, iptsz), imax, ngood
14956 common /qmoyen/qmoy
14957 common /consta/vl, pi, xmat, rpel, qst
14958 common /stis/surxth, suryph, enedep, ecogde, testca
14959 common /etcom/cog(8), exten(17), fd(iptsz)
14965 bcog = sqrt(1.-1./(gcog*gcog))
14968 gref = 1./sqrt(1.-bref*bref)
14970 ccgp = (tcog-tref)*fh*180./pi
14971 ccgd = encog - enref
14973 gpai = f(7, i)/xmat
14974 bpai = sqrt(1.-1./(gpai*gpai))
14975 fd(i) = bpai/bcog*gpai/gcog
14978 testca = exten(1)*exten(2)*exten(3)
14979 if (abs(testca)>1.e-40)
then 14980 qdisp = 2.*sqrt(exten(1))
14981 qmd = exten(1)*exten(3) - exten(2)*exten(2)
14982 surm = 4.*pi*sqrt(qmd)*180./pi
14983 qdp = 2.*sqrt(exten(3))
14984 cor12 = exten(2)/sqrt(exten(1)*exten(3))
14987 qdpde = qdp*180./pi
14998 trqtx = exten(4)*exten(5) - exten(8)*exten(8)
14999 trqpy = exten(6)*exten(7) - exten(9)*exten(9)
15000 qditax = 2.*sqrt(exten(4))
15001 qdiant = 2.*sqrt(exten(5))
15002 qditay = 2.*sqrt(exten(6))
15003 qdianp = 2.*sqrt(exten(7))
15004 surxth = 4.*pi*sqrt(trqtx)
15005 suryph = 4.*pi*sqrt(trqpy)
15006 sqmdv = 4.*pi*sqrt(qmd)
15007 write (16, 52) imax, ngood
15008 52
format (4x,
' TOTAL NUMBER OF PARTICLES :', i5,
' NUMBER OF PARTICLES CONSIDERED :', i6, /)
15010 1557
format (5x,
' *** TRANSVERSE AND LONGITUDINAL STATISTICS')
15011 write (16, 1553) cog(4), cog(5)
15012 1553
format (4x,
' COG COORD X : ', e12.5,
' CM XP :', e12.5,
' MRD')
15013 write (16, 1556) cog(6), cog(7)
15014 1556
format (4x,
' COG COORD Y : ', e12.5,
' CM YP :', e12.5,
' MRD')
15015 write (16, 14) ccgp, ccgd
15016 14
format (4x,
' COG COORD dPHI: ', e12.5,
' deg dW :', e12.5,
' MeV')
15017 write (16, 1552) qditax, qdiant, surxth/pi
15018 1552
format (4x,
' X :', e12.5,
' CM XP :', e12.5,
' MRD EMITTANCE :', e15.8,
' CM.MRD')
15019 write (16, 1555) qditay, qdianp, suryph/pi
15020 1555
format (4x,
' Y :', e12.5,
' CM YP :', e12.5,
' MRD EMITTANCE :', e15.8,
' CM.MRD')
15021 write (16, 154) qdpde, qdisp, sqmdv*180./(pi*pi)
15022 154
format (4x,
' dPHI : ', f7.3,
' deg dW :', 3x, f7.3, 3x,
'MeV EMITTANCE :', e15.8,
' MeV.deg', /)
15044 implicit real *8(a-h, o-z)
15045 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
15046 common /consta/vl, pi, xmat, rpel, qst
15047 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
15048 common /tilt/tipha, tix, tiy, shifw, shifp
15049 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
15050 common /faisc/f(10, iptsz), imax, ngood
15051 common /objet/fo(9, iptsz), imaxo
15052 common /qmoyen/qmoy
15054 common /dyn/tref, vref
15055 common /stis/suryth, surzph, enedep, ecogde, testca
15056 common /newtlt/twissa(3), itwiss
15057 common /histo/centre(6)
15058 common /shif/dtiph, shift
15061 common /tapes/in, ifile, meta
15062 common /etcom/cog(8), exten(17), fd(iptsz)
15064 write (16, 1) tipha, tix, tiy, shifw, shifp
15065 1
format (
' Shift the position of the bunch', /,
' in the z-direction :', e12.5,
' DEG', /, &
15066 ' in the x-direction :', e12.5,
' CM ', /,
' in the y-direction :', e12.5,
' CM ', /, &
15067 ' shift the energy of the cog with :', e12.5,
' MeV', /,
' shift the phase of the cog with :', e12.5, &
15069 tipha = tipha*pi/180.
15070 shifp = shifp*pi/180.
15077 bcog = sqrt(1.-1./(gcog*gcog))
15086 write (16, *)
'*** Before tilt and shift ' 15087 write (16, 24) bcog, tref, tref*deg, encog - xmat
15088 24
format (2x,
'*** the reference particle is the cog:', /,
' REF AND COG: BETA :', e12.5, 2x,
'TOF :', e12.5, &
15089 ' SEC OR: ', e12.5,
' deg', 2x,
' ENERGY :', e12.5,
' MeV', /)
15096 gamref = 1./sqrt(1.-bvref*bvref)
15097 wvref = (gamref-1.)*xmat
15098 write (16, *)
'*** Before tilt and shift ' 15099 write (16, *)
' the reference particle and cog are distinct' 15100 write (16, 16) bvref, tref, tref*deg, wvref, bcog, tcog, tcog*deg, encog - xmat
15101 16
format (2x,
' REF: BETA ', e12.5,
' T.O.F. ', e12.5,
' SEC OR ', e12.5,
' DG',
' ENERGY ', e12.5,
' MeV', //, &
15102 2x,
' COG: BETA ', e12.5,
' T.O.F. ', e12.5,
' SEC OR ', e12.5,
' DG',
' ENERGY ', e12.5,
' MeV', /)
15105 gapi = f(7, i)/xmat
15106 bepi = sqrt(1.-1./(gapi*gapi))
15107 fd(i) = bepi/bcour*gapi/gcour
15114 qdispw = 2.*sqrt(exten(10))
15115 encrt = encog + qdispw
15116 gamcrt = encrt/xmat
15117 bcrt = sqrt(1.-1./(gamcrt*gamcrt))
15119 delv = vcrt - vcour
15123 delxp = 2.*sqrt(exten(5))
15125 delyp = 2.*sqrt(exten(7))
15126 write (16, 22) qdispw, delxp, delyp
15127 22
format (
' half size in energy ', e12.5,
' MeV', /,
' half size in xp ', e12.5,
' mrd', /,
' half size in yp ', &
15132 gapi = f(7, i)/xmat
15133 bpai = sqrt(1.-1./(gapi*gapi))
15135 dv = (vpai-vcour)*tipha/(delv*fh)
15136 f(6, i) = f(6, i) - dv
15137 tcrt = tcrt + f(6, i)
15140 if (delxp/=0.) dlx = f(3, i)*tix/delxp
15141 if (delyp/=0.) dly = f(5, i)*tiy/delyp
15142 f(2, i) = f(2, i) + dlx
15143 f(4, i) = f(4, i) + dly
15145 tcrt = tcrt/float(ngood)
15147 if (shifw/=0. .or. shifp/=0.)
then 15149 enshift = encog + shifw
15150 gshift = enshift/xmat
15151 bshift = sqrt(1.-1./(gshift*gshift))
15152 eshift = enshift - xmat
15154 tshift = tcrt + shtref
15155 deltav = vshift - vcour
15156 deltat = tshift - tcog
15158 if (shifw==0. .and. shifp==0.)
then 15160 eshift = enshift - xmat
15170 f(7, i) = f(7, i) + shifw
15171 gpai = f(7, i)/xmat
15172 bpai = sqrt(1.-1./(gpai*gpai))
15173 f(6, i) = f(6, i) + shtref
15176 if (itwiss==1) tref = tref + tofini
15177 write (16, *)
' ***After tilt and shift ' 15179 gamref = 1./sqrt(1.-bvref*bvref)
15180 wvref = (gamref-1.)*xmat
15181 write (16, 16) bvref, tref, tref*deg, wvref, bshift, tshift, tshift*deg, eshift
15190 if (itwiss/=1)
then 15192 write (11, *) ngood, dum, fh/(2000000.*pi)
15194 f(2, i) = f(2, i) + centre(2)
15195 f(3, i) = f(3, i) + centre(3)
15196 f(4, i) = f(4, i) + centre(4)
15197 f(5, i) = f(5, i) + centre(5)
15198 f(6, i) = f(6, i) + centre(6)
15199 f(7, i) = f(7, i) + centre(1)
15200 etphas = fh*(f(6,i)-tcog)
15202 etener = f(7, i) - xmat
15203 write (11, 777) f(2, i), f(3, i)/1000., f(4, i), f(5, i)/1000., etphas, etener
15205 777
format (6(f13.8,1x))
15208 call stapl(davtot*10.)
15224 implicit real *8(a-h, o-z)
15225 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
15226 common /consta/vl, pi, xmat, rpel, qst
15227 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
15228 common /tilt/tipha, tix, tiy, shifw, shifp
15229 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
15230 common /faisc/f(10, iptsz), imax, ngood
15231 common /objet/fo(9, iptsz), imaxo
15232 common /qmoyen/qmoy
15234 common /dyn/tref, vref
15235 common /stis/suryth, surzph, enedep, ecogde, testca
15236 common /newtlt/twissa(3), itwiss
15237 common /histo/centre(6)
15238 common /shif/dtiph, shift
15241 common /tapes/in, ifile, meta
15242 common /etcom/cog(8), exten(17), fd(iptsz)
15244 write (16, 1) tipha, tix, tiy, shifw, shifp
15245 1
format (
' shift the position around the c.o.g. of the bunch', /,
' with regard to the phase axis :', e12.5, &
15246 ' DEG', /,
' in the x-direction :', e12.5,
' CM ', /,
' in the y-direction :', &
15247 e12.5,
' CM ', /,
' Change of energy position of the c.o.g. :', e12.5,
' MEV', /, &
15248 ' Change of phase position of the c.o.g. :', e12.5,
' DEG', /)
15250 tipha = tipha*pi/180.
15251 shifp = shifp*pi/180.
15258 bcog = sqrt(1.-1./(gcog*gcog))
15259 if (icg/=0 .and. (shifw==0. .or. shifp==0.))
then 15266 write (16, *)
' Before shift ' 15267 write (16, 24) vref, tref, encog - xmat
15268 24
format (2x,
' Note : reference will coincide with the cog', /, 2x,
' velocity :', e12.5,
' CM/SEC', 2x,
'tof :', &
15269 e12.5,
' SEC', /, 2x,
' ENERGY :', e12.5,
' MeV', /)
15276 gamref = 1./sqrt(1.-bvref*bvref)
15277 wvref = (gamref-1.)*xmat
15278 write (16, *)
' Before shift ' 15279 write (16, 16) vref, tref, tref*deg, wvref, vcour, tcog, tcog*deg, encog - xmat
15282 gapi = f(7, i)/xmat
15283 bepi = sqrt(1.-1./(gapi*gapi))
15284 fd(i) = bepi/bcour*gapi/gcour
15291 qdispw = 2.*sqrt(exten(10))
15292 encrt = encog + qdispw
15293 gamcrt = encrt/xmat
15294 bcrt = sqrt(1.-1./(gamcrt*gamcrt))
15296 delv = vcrt - vcour
15300 delxp = 2.*sqrt(exten(5))
15302 delyp = 2.*sqrt(exten(7))
15303 write (16, 22) qdispw, delxp, delyp
15304 22
format (
' half size in energy ', e12.5,
' MeV', /,
' half size in xp ', e12.5,
' mrd', /,
' half size in yp ', &
15309 gapi = f(7, i)/xmat
15310 bpai = sqrt(1.-1./(gapi*gapi))
15312 dv = (vpai-vcour)*tipha/(delv*fh)
15313 f(6, i) = f(6, i) - dv
15314 tcrt = tcrt + f(6, i)
15317 if (delxp/=0.) dlx = f(3, i)*tix/delxp
15318 if (delyp/=0.) dly = f(5, i)*tiy/delyp
15319 f(2, i) = f(2, i) + dlx
15320 f(4, i) = f(4, i) + dly
15322 tcrt = tcrt/float(ngood)
15326 if (shifw/=0. .or. shifp/=0.)
then 15329 enshift = encog + shifw
15330 gshift = enshift/xmat
15331 bshift = sqrt(1.-1./(gshift*gshift))
15332 eshift = enshift - xmat
15334 tshift = tcrt + shtref
15338 eshift = enshift - xmat
15344 deltav = vshift - vcour
15345 deltat = tshift - tcog
15352 write (16, *)
'tofini,tcrt=', tofini, tcrt, tcrt*deg
15354 write (16, *)
'Reference and COG are independent', icg
15356 write (16, *)
'Reference and COG coincide', icg
15359 f(7, i) = f(7, i) + shifw
15360 gpai = f(7, i)/xmat
15361 bpai = sqrt(1.-1./(gpai*gpai))
15362 f(6, i) = f(6, i) + shtref
15365 if (itwiss==1) tref = tref + tofini
15366 write (16, *)
' After shift ' 15368 gamref = 1./sqrt(1.-bvref*bvref)
15369 wvref = (gamref-1.)*xmat
15370 write (16, 16) vref, tref, tref*deg, wvref, vshift, tshift, tshift*deg, eshift
15371 16
format (2x,
' REFERENCE: VELOCITY :', e12.5,
' CM/SEC, T.O.F. :', e12.5,
' SEC OR ', e12.5,
' DG', /, 3x, &
15372 ' ENERGY : ', e12.5,
' MeV', /, 2x,
' C.O.G.: VELOCITY :', e12.5,
' CM/SEC, T.O.F. :', e12.5,
' SEC OR ', &
15373 e12.5,
' DG', /, 3x,
' ENERGY : ', e12.5,
' MeV', //)
15383 if (itwiss/=1)
then 15384 write (11, *) ngood
15386 f(2, i) = f(2, i) + centre(2)
15387 f(3, i) = f(3, i) + centre(3)
15388 f(4, i) = f(4, i) + centre(4)
15389 f(5, i) = f(5, i) + centre(5)
15390 f(6, i) = f(6, i) + centre(6)
15391 f(7, i) = f(7, i) + centre(1)
15392 etphas = fh*(f(6,i)-tcog)
15394 etener = f(7, i) - xmat
15395 write (11, 777) f(2, i), f(3, i), f(4, i), f(5, i), etphas, etener
15397 777
format (6(f13.8,1x))
15400 call stapl(davtot*10.)
15408 implicit real *8(a-h, o-z)
15409 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
15410 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
15411 common /tapes/in, ifile, meta
15412 common /faisc/f(10, iptsz), imax, ngood
15413 common /etcom/cog(8), exten(17), fd(iptsz)
15414 common /dyn/tref, vref
15415 common /dyni/vrefi, trefi, fhinit, acpt
15416 common /qmoyen/qmoy
15417 common /objet/fo(9, iptsz), imaxo
15418 common /consta/vl, pi, xmat, rpel, qst
15419 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
15420 dimension back(9, iptsz)
15421 logical chasit, acpt
15422 common /mcs/imcs, ncstat, cstat(20)
15426 write (16, *)
'Physical acceptance has:' 15427 write (16, *) imaxo,
' particles at origin' 15439 back(i, j) = f(i, j)
15448 eprt = fo(7, j) - xmat
15450 f3 = fo(3, j)/1000.
15452 f5 = fo(5, j)/1000.
15455 open (23, file=
'input_kept.dst', status=
'unknown')
15457 write (23, *) ngood, dummy, fh/(2000000.*pi)
15461 f(jj, j) = fo(jj, nold)
15464 eprt = f(7, j) - xmat
15470 write (23, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(9, j)
15472 write (23, 100) f2, f3/1000., f4, f5/1000., tprt, eprt
15477 write (16, *)
'Starting good particles graphics for ACCEPT card' 15483 open (23, file=
'input_lost.dst', status=
'unknown')
15485 write (23, *) imax - ngood, dummy, fh/(2000000.*pi)
15488 do k = ngood + 1, imax
15491 f(jj, j) = fo(jj, nold)
15494 eprt = f(7, j) - xmat
15500 write (23, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(9, j)
15502 write (23, 100) f2, f3/1000., f4, f5/1000., tprt, eprt
15506 ngood = imax - ngood
15507 100
format (6(f15.8,1x))
15508 101
format (7(f15.8,1x))
15511 write (16, *)
'Starting lost particles graphics for ACCEPT card' 15520 f(i, j) = back(i, j)
15533 implicit real *8(a-h, o-z)
15534 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
15535 character *80 text, patitl
15536 common /consta/vl, pi, xmat, rpel, qst
15537 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
15538 common /faisc/f(10, iptsz), imax, ngood
15539 common /stis/suryth, surzph, enedep, ecogde, testca
15540 common /fene/wdisp, wphas, wx, wy, rlim, ifw
15541 common /dyn/tref, vref
15542 common /tapes/in, ifile, meta
15543 common /etcom/cog(8), exten(17), fd(iptsz)
15544 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
15545 common /grparm/glim(4, 2), glim1(4, 2), glim2(4, 2), patitl, ngraphs(100), idwdp, igrprm, ngrafs
15546 common /mcs/imcs, ncstat, cstat(20)
15547 common /zones/frms(6), nzone
15549 dimension oldcog(7), slim(4, 2)
15550 dimension xx(iptsz), yy(iptsz), cs(iptsz)
15556 if (igrprm==0)
then 15562 read (in, *) idwdp, rmsmtp
15565 read (in, *)((glim(j,k),k=1,2), j=1, 4)
15567 if (igrprm==1)
then 15570 if (igrprm==2)
then 15575 slim(j, k) = glim(j, k)
15576 glim(j, k) = glim1(j, k)
15580 if (igrprm==3)
then 15585 slim(j, k) = glim(j, k)
15586 glim(j, k) = glim2(j, k)
15597 bcog = sqrt(1.-1./(gcog*gcog))
15606 enprt = encog - xmat
15608 rmssz = sqrt(rmsmtp)
15611 qdisp = rmssz*sqrt(exten(1))
15612 qmd = exten(1)*exten(3) - exten(2)*exten(2)
15613 qmdw = exten(10)*exten(3) - exten(11)*exten(11)
15614 surm = rmsmtp*180.*sqrt(qmd)
15615 qdp = rmssz*sqrt(exten(3))
15616 cor12 = exten(2)/sqrt(exten(1)*exten(3))
15617 pent12 = sqrt(exten(1)/exten(3))/cor12
15618 pent21 = sqrt(exten(1)/exten(3))*cor12
15619 qdpde = qdp*180./pi
15620 trqty = exten(4)*exten(5) - exten(8)*exten(8)
15621 trqpz = exten(6)*exten(7) - exten(9)*exten(9)
15622 suryth = rmsmtp*pi*sqrt(trqty)
15623 surzph = rmsmtp*pi*sqrt(trqpz)
15624 qditay = rmssz*sqrt(exten(4))
15625 qdiant = rmssz*sqrt(exten(5))
15626 qdita = rmssz*sqrt(exten(6))
15627 qdianp = rmssz*sqrt(exten(7))
15628 write (16, *)
' *** PLOT Ellips for ', rmsmtp,
' RMS' 15629 write (16,
'(a)') text
15630 write (16, 1557) imax, ngood
15631 1557
format (1x,
' *** GRAPH, TOTAL NUMBER OF PARTICLES : ', i6,
' PARTICLES KEPT : ', i6, //, &
15632 ' *** HORIZONTAL phase plane ', /)
15633 write (16, 1553) cog(4), cog(5)
15634 1553
format (4x,
' C.O.G. :', 5x,
' X : ', e12.5,
' CM XP :', e12.5,
' MRD', /)
15635 if (rmsmtp>teps)
then 15636 write (16, 1552) qditay, qdiant, suryth
15637 1552
format (4x,
' 1/2 EXTENSION X : ', e12.5,
' CM', /, 4x,
' 1/2 EXTENSION XP : ', e12.5,
' MRD', 4x, &
15638 ' SURFACE : ', e15.8,
' CM.MRD', /)
15641 1554
format (
' *** VERTICAL phase plane ', /)
15642 write (16, 1556) cog(6), cog(7)
15643 1556
format (4x,
' C.O.G :', 5x,
' Y : ', e12.5,
' CM YP :', e12.5,
' MRD', /)
15644 if (rmsmtp>teps)
then 15645 write (16, 1555) qdita, qdianp, surzph
15646 1555
format (4x,
' 1/2 EXTENSION Y : ', e12.5,
' CM', /, 4x,
' 1/2 EXTENSION YP : ', e12.5,
' MRD', 4x, &
15647 ' SURFACE : ', e15.8,
' CM.MRD', /)
15658 if (nzone/=0) igrtyp = 11
15659 if (imcs==1) igrtyp = 6
15660 write (66, *) igrtyp
15661 if (igrtyp==6)
then 15662 write (66, *) ncstat
15663 write (66, *)(cstat(j), j=1, ncstat)
15665 if (igrtyp==11)
then 15666 write (66, *) nzone
15667 write (66, *)(frms(j), j=2, nzone),
' 0.' 15672 write (66, *) - xx(1), xx(1), -yy(1), yy(1)
15677 xii = -qdiant + step*float(i-1)
15678 yy(i) = xii + cog(5)
15681 ttc = exten(4)*xii**2 - trqty*rmsmtp
15682 ttcb = ttb**2 - ttc*tta
15683 if (ttcb<=0.) ttcb = 0.
15689 yi = ttb/tta - sqrt(quot)
15690 yii = ttb/tta + sqrt(quot)
15692 xx(i) = yi + cog(4)
15693 xx(202-i) = yii + cog(4)
15696 write (66, *) xx(i), yy(i)
15708 write (66, *) ngood
15712 write (66, *) xx(i), yy(i)
15716 write (66, *) xx(i), yy(i), f(10, i)
15721 write (66, *) xx(i), yy(i), cs(i)
15727 write (66, *) - xx(1), xx(1), -yy(1), yy(1)
15732 xii = -qdianp + step*float(i-1)
15733 yy(i) = xii + cog(7)
15736 ttc = exten(6)*xii**2 - trqpz*rmsmtp
15737 ttcb = ttb**2 - ttc*tta
15738 if (ttcb<=0.) ttcb = 0.
15744 yi = ttb/tta - sqrt(quot)
15745 yii = ttb/tta + sqrt(quot)
15747 xx(i) = yi + cog(6)
15748 xx(202-i) = yii + cog(6)
15751 write (66, *) xx(i), yy(i)
15758 write (66, *) ngood
15762 write (66, *) xx(i), yy(i)
15766 write (66, *) xx(i), yy(i), f(10, i)
15771 write (66, *) xx(i), yy(i), cs(i)
15778 write (66, *) - xx(1), xx(1), -yy(1), yy(1)
15782 write (66, *) - xx(1), xx(1), -yy(1), yy(1)
15785 gref = 1./sqrt(1.-bref*bref)
15786 wref = xmat*(gref-1.)
15787 gcog = 1./sqrt(1.-bcog*bcog)
15788 wcog = xmat*(gcog-1.)
15789 write (16, 22) wref, tref, wcog, tcog
15790 22
format (
' *** LONGITUDINAL phase plane ', /, 6x,
' REFERENCE : ',
' ENERGY: ', e15.8,
' (MeV), TOF: ', e15.8, &
15791 ' (SEC)', /, 6x,
' COG : ',
' ENERGY: ', e15.8,
' (MeV), TOF: ', e15.8,
' (SEC)', /)
15792 write (16, 167) qmd, surm, qdp, qdpde, qdisp, cor12, pent12, pent21
15793 167
format (3x,
' ***',
' 2nd ORDER MOMENTS :', e12.5,
' (RD DP/P)**2',
' SURFACE : ', e12.5,
' (DEG DP/P)', /, 6x, &
15794 ' 1/2 EXTENSION PHASE : ', e12.5,
' RD ',
' OR ', e12.5,
' DEG', /, 6x,
' 1/2 EXTENSION DISPERSION : ', e15.8, &
15795 ' IN DP/P ', /, 6x,
' CORRELATION COEF : ', e15.8, /, 6x,
' DISPERSION SLOPE: ', e15.8,
' (DP/P)/RD ', /, 6x, &
15796 ' PHASE SLOPE : ', e15.8,
' (DP/P)/RD ')
15799 tta = exten(3)*180.*180./(pi*pi)
15801 xii = -qdpde + step*float(i-1)
15804 ttb = exten(11)*xii*180./pi
15805 ttc = exten(10)*xii**2 - qmdw*rmsmtp*180.*180./(pi*pi)
15806 ttcb = ttb**2 - ttc*tta
15807 if (ttcb<=0.) ttcb = 0.
15813 yi = ttb/tta - sqrt(quot)
15814 yii = ttb/tta + sqrt(quot)
15823 write (66, *) xx(i), yy(i)
15828 gref = 1./sqrt(1.-bref*bref)
15829 enihrf = xmat*(gref-1.)
15830 phihrf = fh*(tcog-tref)*180./pi
15833 ayy = encog - enihrf - xmat
15834 write (66, *) xx(i) + axx, yy(i) + ayy
15841 xx(i) = fh*(f(6,i)-tcog)*180./pi
15842 yy(i) = f(7, i) - encog
15843 if (imcs==1) cs(i) = f(9, i)
15847 xx(i) = fh*(f(6,i)-tref)*180./pi
15848 yy(i) = f(7, i) - enihrf - xmat
15849 if (imcs==1) cs(i) = f(9, i)
15853 write (66, *) ngood
15857 write (66, *) xx(i), yy(i)
15861 write (66, *) xx(i), yy(i), f(10, i)
15866 write (66, *) xx(i), yy(i), cs(i)
15871 if (igrprm==2 .or. igrprm==3)
then 15875 glim(j, k) = slim(j, k)
15882 end subroutine ytzp 15887 subroutine grcomp(text, iskale)
15888 implicit real *8(a-h, o-z)
15889 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
15890 character *80 text, patitl
15891 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
15892 common /faisc/f(10, iptsz), imax, ngood
15893 common /stis/suryth, surzph, enedep, ecogde, testca
15894 common /fene/wdisp, wphas, wx, wy, rlim, ifw
15895 common /consta/vl, pi, xmat, rpel, qst
15896 common /dyn/tref, vref
15897 common /tapes/in, ifile, meta
15898 common /etcom/cog(8), exten(17), fd(iptsz)
15899 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
15900 common /grparm/glim(4, 2), glim1(4, 2), glim2(4, 2), patitl, ngraphs(100), idwdp, igrprm, ngrafs
15901 common /mcs/imcs, ncstat, cstat(20)
15902 common /zones/frms(6), nzone
15903 common /hist/xpos(200), xn(200), ypos(200), yn(200), zpos(200), zn(200), ixt, iyt, izt
15904 common /hist1/xps(200), xpn(200), yps(200), ypn(200), zps(200), zpn(200), ixpt, iypt, izpt
15906 dimension xx(iptsz), yy(iptsz), cs(iptsz)
15907 dimension slim(4, 2)
15911 tcog = f(6, i) + tcog
15913 tcog = tcog/float(ngood)
15914 if (igrprm==1)
then 15917 if (igrprm==2)
then 15922 slim(j, k) = glim(j, k)
15923 glim(j, k) = glim1(j, k)
15927 if (igrprm==3)
then 15932 slim(j, k) = glim(j, k)
15933 glim(j, k) = glim2(j, k)
15938 write (16, *)
'LIMITS', ((glim(j,k),k=1,2), j=1, 4)
15940 xyliz = glim(4, 1)*vref*pi/(180.*fh)
15943 dstrly = glim(4, 2)
15953 if (nzone/=0) igrtyp = 12
15954 if (imcs==1) igrtyp = 7
15957 if (iskale==1)
then 15958 write (66, *) igrtyp + 15
15959 write (66, *) dstrly
15961 write (66, *) igrtyp
15963 if (igrtyp==7)
then 15964 write (66, *) ncstat
15965 write (66, *)(cstat(j), j=1, ncstat)
15967 if (igrtyp==12)
then 15968 write (66, *) nzone
15969 write (66, *)(frms(j), j=2, nzone),
' 0.' 15975 write (66, *) - xx(1), xx(1), -yy(1), yy(1)
15985 gpai = f(7, i)/xmat
15986 bpai = sqrt(1.-1./(gpai*gpai))
15987 xx(i) = (tcog-f(6,i))*vl*bpai
15993 gpai = f(7, i)/xmat
15994 bpai = sqrt(1.-1./(gpai*gpai))
15995 xx(i) = (tref-f(6,i))*vl*bpai
16000 write (66, *) ngood
16004 write (66, *) xx(i), yy(i)
16008 write (66, *) xx(i), yy(i), f(10, i)
16013 write (66, *) xx(i), yy(i), cs(i)
16021 write (66, *) - xx(1), xx(1), -yy(1), yy(1)
16026 gpai = f(7, i)/xmat
16027 bpai = sqrt(1.-1./(gpai*gpai))
16028 xx(i) = (tcog-f(6,i))*vl*bpai
16034 gpai = f(7, i)/xmat
16035 bpai = sqrt(1.-1./(gpai*gpai))
16036 xx(i) = (tref-f(6,i))*vl*bpai
16041 write (66, *) ngood
16045 write (66, *) xx(i), yy(i)
16049 write (66, *) xx(i), yy(i), f(10, i)
16054 write (66, *) xx(i), yy(i), cs(i)
16062 write (66, *) xpos(i), xn(i)
16066 write (66, *) ypos(i), yn(i)
16070 write (66, *) zpos(i), zn(i)
16075 write (66, *) xps(i), xpn(i)
16079 write (66, *) yps(i), ypn(i)
16083 write (66, *) zps(i), zpn(i)
16085 if (igrprm==2 .or. igrprm==3)
then 16089 glim(j, k) = slim(j, k)
16102 implicit real *8(a-h, o-z)
16104 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
16105 common /ttfs/dynt(maxcell), dyntp(maxcell), dyntpp(maxcell), dyne0(maxcell), dynph(maxcell), dynlg(maxcell), &
16108 common /midgap/enmil, vapmi
16109 common /azmtch/dlg, xmcph, xmce
16110 common /azlist/icont, iprin
16111 common /itvole/itvol, imamin
16112 common /func/a(200), ylg, atte, ncel, nharm
16114 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
16115 common /ttfcb/t3k, t4k, s3k, s4k
16116 common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
16117 common /jacob/gaks, gaps
16118 common /iter1/dxdki, dphii, phi, dkmske, dkmsphi, retph, xkmi, xkm, dxk00, tke, t1ke, ske, s1ke, phiwc, xk1i, &
16120 common /faisc/f(10, iptsz), imax, ngood
16121 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
16122 common /rfield/ifield
16123 common /qmoyen/qmoy
16125 common /cdek/dwp(iptsz)
16126 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
16127 common /consta/vl, pi, xmat, rpel, qst
16128 common /dyn/tref, vref
16129 common /compt/nrres, nrtre, nrbunc, nrdbun
16130 common /compt1/ndtl, ncavmc, ncavnm
16131 common /fene/wdisp, wphas, wx, wy, rlim, ifw
16132 common /tapes/in, ifile, meta
16133 common /ranec1/dummy(6)
16134 common /etcom/cog(8), exten(17), fd(iptsz)
16135 common /speda/dave, idave
16136 common /shif/dtiph, shift
16137 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
16138 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
16140 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
16141 common /appel/irstay, ilost, iavp, ispcel
16143 common /pstpla/tstp
16144 common /femt/iemgrw, iemqesg
16145 common /mode/eflvl, rflvl
16146 common /aerp/vphase, vfield, ierpf
16147 common /tofev/ttvols
16153 logical iesp, ichaes, irstay, iavp, ispcel, ifield, iemgrw
16154 logical shift, chasit, itvol, imamin, dave
16161 ncavmc = ncavmc + 1
16164 write (6, 8254) nrtre, nrres, cr
16165 8254
format (
'Transport element:', i5,
' Accelerating element:', i5, a1, $)
16166 write (16, *)
' CAVITY N :', nrres
16185 read (in, *) xesln, dphase, ffield, isec, idum
16186 ffield = 1. + ffield/100.
16197 scdist = ylg - abs(xesln)
16203 scdist = ylg - abs(xesln)
16206 if (itvol .and. imamin)
then 16208 ottvol = fh*ttvols*180./pi
16212 xkpi = (xkpi-float(ixkpi))*360.
16213 dphase = dphase - xkpi
16223 write (16, 150) fh/(2.*pi), ylg, atte, ffield, ncel
16224 150
format (4x,
'FREQUENCY :', e12.5,
' Hertz', /, 4x,
'FIELD LENGTH :', e12.5,
' cm', /, 4x, &
16225 'FIELD FACTOR (UNITS CONVERSION) :', e12.5, /, 4x,
'FIELD FACTOR (ATTENUATION) :', f12.6, /, 4x, &
16226 'FIELD DIVIDED IN: ', i4,
' SECTIONS ')
16227 if (.not. imamin)
write (16, *)
' PHASE OFFSET: ', dphete,
' DEG' 16228 if (imamin)
write (16, 1501) dphete, dphase, xkpi
16229 1501
format (4x,
'PHASE OFFSET (before adjustment): ', e12.5,
' deg', /, 4x,
'PHASE OFFSET (after adjustment): ', &
16230 e12.5,
' deg', /, 4x,
'ADJUSTMENT ON THE PHASE OFFSET: ', e12.5,
' deg')
16234 tk =
tta0(beref)/2.*ffield
16235 sk =
tsb0(beref)/2.*ffield
16237 pcrest = atan(-sk/tk)
16238 ddwc = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
16239 if (ddwc<0.) pcrest = pcrest + pi
16242 if (itvol) ttvol = ttvols*fh
16249 dav1(idav, 1) = ylg*10.
16250 dav1(idav, 2) = ye0*100.
16251 tstp = (davtot+ylg*xpsc)*10.
16252 davtot = davtot + ylg
16253 dav1(idav, 24) = davtot*10.
16254 dav1(idav, 40) = fh
16255 if (iprf==1)
call stapl(dav1(idav,24))
16261 bcog = sqrt(1.-1./(gcog*gcog))
16266 gamref = 1./sqrt(1.-(beref*beref))
16267 enref = xmat*gamref
16268 trefdg = tref*fh*180./pi
16294 if (dav1(idav,3)==1.)
write (16, *)
' ****reference and cog evolve independently' 16295 if (dav1(idav,3)==0.)
write (16, *)
' **** the reference is the cog ' 16297 178
format (/,
' Dynamics at the input', /, 5x,
' BETA GAMMA ENERGY(MeV) ',
' TOF(deg) TOF(sec)')
16298 write (16, 1788) bcog, gcog, encog - xmat, tcog*fh*180./pi, tcog
16299 1788
format (
' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
16300 enrprin = enref - xmat
16301 write (16, 165) beref, gamref, enrprin, tref*fh*180./pi, tref
16302 165
format (
' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
16308 ddw = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
16309 enrefs = enref + ddw
16311 bets = sqrt(1.-1./(gams*gams))
16312 bemy = (gams+gamref)/(gams*bets+gamref*beref)
16314 tk0 =
tta0(bemy)/2.*ffield
16315 tpk0 =
tta1(bemy)/2.*ffield
16316 tppk0 =
tta2(bemy)/2.*ffield
16317 tp3k0 =
tta3(bemy)/2.*ffield
16318 tp4k0 =
tta4(bemy)/2.*ffield
16319 sk0 =
tsb0(bemy)/2.*ffield
16320 spk0 =
tsb1(bemy)/2.*ffield
16321 sppk0 =
tsb2(bemy)/2.*ffield
16322 sp3k0 =
tsb3(bemy)/2.*ffield
16323 sp4k0 =
tsb4(bemy)/2.*ffield
16335 pcrest = atan(-sk0/tk0)
16336 ddwc = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
16337 if (ddwc<0.) pcrest = pcrest + pi
16339 call crest(bemy, eqvl, xpos, sqcttf, ffield)
16353 dts = (tk*t1k+sk*s1k)/(tk*tk+sk*sk)
16357 phslip = -4.*atan(3.2*dts/eqvl)
16358 if (phslip/=0.)
then 16361 gx = 1./tan(til2) - 1./til2 - fk1/eqvlp
16362 gpx = -1./(sin(til2)*sin(til2)) + 1./(til2*til2)
16363 til2 = til2 - gx/gpx
16364 hx = 1./tan(til2) - 1./til2
16370 asdl = peqvl - eqvl/2.
16371 f0 =
xitl0(gamref, gams, bemy, saphi, aqst)
16372 delwrm = (f0-gamref)*xmat
16373 enrs = enref + delwrm
16375 bets = sqrt(1.-1./(gams*gams))
16377 coeph = fh*aqst/(vl*xmat)
16378 f3 =
xitl3(gamref, gams, bemy, it, saphi, aqst)
16381 xkm = delphr/eqvl + xk2*(1.+asdl/eqvl) - xk1*asdl/eqvl
16384 tk =
tta0(bemy)/2.*ffield
16385 t1k =
tta1(bemy)/2.*ffield
16386 sk =
tsb0(bemy)/2.*ffield
16387 s1k =
tsb1(bemy)/2.*ffield
16390 pcrest = atan(-sk/tk)
16391 ddwc = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
16392 if (ddwc<0.) pcrest = pcrest + pi
16398 imedi = int(vapmi/360.+.4)
16399 dcemd = vapmi - 360.*imedi
16400 write (16, 773) nrres, enmil, vapmi, dcemd
16401 773
format (2x,
' AT THE MIDDLE OF THE CAVITY:', i4, /, 2x,
' *ENERGY :', e12.5,
' MEV *PHASE :', e12.5,
' DEG', &
16402 2x,
' *SLIP OF PHASE :', e12.5,
' deg', /)
16403 dcemd = dcemd*pi/180.
16406 dphase = dphase*pi/180.
16407 saphi = pcrest + dphase + ttvol - dcemd
16408 ddw = aqst*(tk0*cos(saphi)-sk0*sin(saphi))
16420 dts = (tk*t1k+sk*s1k)/(tk*tk+sk*sk)
16423 phslip = -4.*atan(3.2*dts/eqvl)
16424 if (phslip/=0.)
then 16427 gx = 1./tan(til2) - 1./til2 - fk1/eqvlp
16428 gpx = -1./(sin(til2)*sin(til2)) + 1./(til2*til2)
16429 til2 = til2 - gx/gpx
16430 hx = 1./tan(til2) - 1./til2
16436 asdl = peqvl - eqvl/2.
16438 f0 =
xitl0(gamref, gams, bemy, saphi, aqst)
16439 delwrm = (f0-gamref)*xmat
16440 enrs = enref + delwrm
16442 bets = sqrt(1.-1./(gams*gams))
16445 coeph = fh*aqst/(vl*xmat)
16446 f2 =
xitl3(gamref, gams, bemy, it, saphi, aqst)
16449 xkm = delphr/eqvl + xk2*(1.+asdl/eqvl) - xk1*asdl/eqvl
16452 tk =
tta0(bemy)/2.*ffield
16453 t1k =
tta1(bemy)/2.*ffield
16454 t2k =
tta2(bemy)/2.*ffield
16455 t3k =
tta3(bemy)/2.*ffield
16456 t4k =
tta4(bemy)/2.*ffield
16457 sk =
tsb0(bemy)/2.*ffield
16458 s1k =
tsb1(bemy)/2.*ffield
16459 s2k =
tsb2(bemy)/2.*ffield
16460 s3k =
tsb3(bemy)/2.*ffield
16461 s4k =
tsb4(bemy)/2.*ffield
16462 pcrest = atan(-sk/tk)
16463 ddwc = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
16464 if (ddwc<0.) pcrest = pcrest + pi
16465 dphii = (xk1-xk2)*eqvl/10. + (xkp1+xkp2)/120.*eqvl*eqvl + (xk1-xkm)*asdl
16470 saphi = pcrest + dphase + ttvol - dcemd + dphii
16472 savph = saphi*180./pi
16474 cfh = fh/(vl*2.*xmat)
16475 ckh = qmoy*qmoy/(4.*xmat*xmat)
16476 dphii = (xk1-xk2)*eqvl/10. + (xkp1+xkp2)/120.*eqvl*eqvl + (xk1-xkm)*asdl
16477 phares = saphi + xk2*ylg + delphr
16483 trefs = tref + (xk2*ylg+delphr)/fh
16488 phared = (phares-saphi)*180./pi
16489 tredg = fh*trefs*180./pi
16506 write (16, *)
' PARAMETERS RELATING TO THE REFERENCE PARTICLE ' 16507 write (16, *)
'***********************************************' 16508 write (16, *)
' ENERGY GAIN(MeV) ', delwrm,
' TOF ', tredg,
' DEG' 16509 write (16, *)
' PHASE JUMP(DG) ', delphr*180./pi
16510 write (16, *)
' SLIP OF PHASE AT THE INPUT(DG) ', sapho*180./pi
16511 write (16, *)
' PHASE OF RF AT ENTRANCE(DG) ', savph
16512 write (16, *)
' AVERAGE k (cm-1) (freq./velocity): ', xkm
16513 write (16, *)
' Associated drift length ', asdl,
' (cm)' 16514 write (16, *)
' Equivalent field length ', eqvl,
' cm center at ', xpos,
' cm' 16515 write (16, *)
' TRANSIT TIME FACTORS AND DERIVATIVES (MeV,cm):' 16516 write (16, *)
' T ', tk, t1k, t2k, t3k, t4k
16517 write (16, *)
' S ', sk, s1k, s2k, s3k, s4k
16518 write (16, *)
' PHASE SLIP(DEG) ', phslip*180./pi
16519 write (16, *)
' CREST PHASE OF RF (DEG) ', pcrest*180./pi
16520 write (16, *)
' MAGNITUDE ', sqcttf,
' MV/cm' 16521 t0s = sqrt(tk*tk+sk*sk)
16522 write (16, *)
' T0 ', t0s
16524 call gap(gamref, saphi, gams, delphr)
16529 bcog = sqrt(1.-1./(gcog*gcog))
16537 dav1(idav, 38) = dphete
16538 dav1(idav, 39) = dphase*180./pi
16540 dav1(idav, 38) = dphete
16543 3777
format (/,
' Dynamics at the output', /, 5x,
' BETA dW(MeV) ENERGY(MeV) ',
' TOF(deg) TOF(sec)')
16544 engain = encog - enold
16545 write (16, 3473) bets, delwrm, enrs - xmat, fh*trefs*180./pi, trefs
16546 3473
format (
' REF ', f7.5, 3x, f10.6, 3x, e12.5, 3x, e12.5, 3x, e12.5)
16547 write (16, 1789) bcog, engain, encog - xmat, tcog*fh*180./pi, tcog
16548 1789
format (
' COG ', f7.5, 3x, f10.6, 3x, e12.5, 3x, e12.5, 3x, e12.5)
16549 testca = exten(1)*exten(2)*exten(3)
16552 if (abs(testca)>epsil)
then 16553 qdisp = 2.*sqrt(exten(1))
16554 qmd = exten(1)*exten(3) - exten(2)**2
16555 sqmdv = 4.*pi*sqrt(qmd)
16556 surm = 4.*pi*sqrt(qmd)*180./pi
16557 qdp = 2.*sqrt(exten(3))
16558 cor12 = exten(2)/sqrt(exten(1)*exten(3))
16561 qdpde = qdp*180./pi
16573 trqtx = exten(4)*exten(5) - exten(8)**2
16574 trqpy = exten(6)*exten(7) - exten(9)**2
16575 qditax = 2.*sqrt(exten(4))
16576 qdiant = 2.*sqrt(exten(5))
16577 qditay = 2.*sqrt(exten(6))
16578 qdianp = 2.*sqrt(exten(7))
16579 surxth = 4.*pi*sqrt(trqtx)
16580 suryph = 4.*pi*sqrt(trqpy)
16598 call stapl(dav1(idav,24))
16602 dav1(idav, 16) = bcog*surxth*10./(pi*sqrt(1.-bcog*bcog))
16605 dav1(idav, 21) = bcog*suryph*10./(pi*sqrt(1.-bcog*bcog))
16606 dav1(idav, 25) = nrres
16607 dav1(idav, 30) = ngood
16615 emns = 1.e12*sqmdv/(pi*fh)
16617 tcgprt = fh*tcog*180./pi
16618 trfprt = fh*tref*180./pi
16624 trnsms = 100.*float(ngood)/float(imax)
16625 if (ncavmc==1)
write (50, *)
'# cavmc.dmp' 16626 if (ncavmc==1)
write (50, *)
'# cav Z trans ', &
16627 'PHIs TOF(COG) COG Wcog TOF(REF) ', &
16628 ' REF Wref Ex,RMS,n Ey,RMS,n El,RMS' 16629 if (ncavmc==1)
write (50, *)
'# # (m) (%) ', &
16630 '(deg) (deg) beta (MeV) (deg) ', &
16631 ' beta (MeV) (mm.mrad) (mm.mrad) (ns.keV)' 16632 write (50, 7023) nrres, 0.001*dav1(idav, 24), trnsms, dphete, tcgprt, bcog, encog - xmat, trfprt, bets, &
16633 enrs - xmat, 0.25*dav1(idav, 16), 0.25*dav1(idav, 21), 0.25*emns
16634 7023
format (1x, i4, 1x, e12.5, 1x, f6.2, 1x, f7.2, 1x, 2(e14.7,1x,f7.5,1x,e14.7,1x), 3(e12.5,1x))
16638 gref = 1./sqrt(1.-bets*bets)
16639 xmor = xmat*bets*gref
16640 boro = 33.356*xmor*1.e-01/aqst
16641 write (16, *) ilost,
' particles lost in cavity ', nrres
16652 implicit real *8(a-h, o-z)
16653 common /consta/vl, pi, xmat, rpel, qst
16654 common /rfield/ifield
16655 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
16656 common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
16657 common /mode/eflvl, rflvl
16658 common /cavnum1/xnh, xpas, ffield, npt
16659 common /kcell/avrg(15)
16667 read (20, *) xspl(1), yspl(1)
16668 yspl(1) = yspl(1)*att
16669 xspl(1) = xspl(1)*100.
16672 read (20, *) xspl(i), yspl(i)
16673 if (xspl(i)==0.)
go to 10
16674 xspl(i) = xspl(i)*100.
16675 yspl(i) = yspl(i)*att
16683 xspl(it) = xspl(it) - tdep
16687 xpas = (xspl(3)-xspl(2))/part
16691 if (xcour>xspl(npt))
go to 20
16692 yf(i) =
spline(npt, xcour)
16694 xcour = xcour + xpas
16707 xlim(ncell) = xf(1)
16709 if (xf(i)==0.)
then 16711 xlim(ncell) = xlimf
16714 if (yf(i)*yf(i-1)<0.)
then 16716 xlim(ncell) = xf(i)
16718 npoint(ncell) = npoint(ncell) + 1
16722 flength = xlim(ncell)
16725 write (16, 100) ncell, flength, att, fhc
16726 100
format (
' Number of cells: ', i3,
' field length: ', e12.5,
'cm',
' field factor: ', e12.5,
' frequency: ', e12.5, &
16733 write (16, 200) i, xlim(i), xlim(i+1), avrg(i)
16735 200
format (
' Cell number ', i3,
' lower limit ', e12.5,
' cm ',
' upper limit ', e12.5,
' cm ',
'average ', e12.5, &
16744 implicit real *8(a-h, o-z)
16745 common /cavnum1/xnh, xpas, fmult, npt
16746 common /consta/vl, pi, xmat, rpel, qst
16747 common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
16748 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
16749 common /kcell/avrg(15)
16758 xlcel = xlim(inc+1) - xlim(inc)
16759 xlpos = xlpos + xlcel
16760 xpas = xlcel/float(isce)
16766 if (xpat<(xlcel-estop))
then 16768 z1 = (xnh+0.20)*xpas
16769 z2 = (xnh+0.40)*xpas
16770 z3 = (xnh+0.60)*xpas
16771 z4 = (xnh+0.80)*xpas
16772 z5 = (xnh+1.00)*xpas
16773 fpos0 = xnh*xpas + xlcum
16774 fpos1 = (xnh+0.20)*xpas + xlcum
16775 fpos2 = (xnh+0.40)*xpas + xlcum
16776 fpos3 = (xnh+0.60)*xpas + xlcum
16777 fpos4 = (xnh+0.80)*xpas + xlcum
16778 fpos5 = (xnh+1.0)*xpas + xlcum
16779 tspl0 =
spline(npt, fpos0)
16780 tspl1 =
spline(npt, fpos1)
16781 tspl2 =
spline(npt, fpos2)
16782 tspl3 =
spline(npt, fpos3)
16783 tspl4 =
spline(npt, fpos4)
16784 tspl5 =
spline(npt, fpos5)
16792 tspl11 = 19.*xspl0 + 75.*xspl1 + 50.*xspl2 + 50.*xspl3 + 75.*xspl4 + 19.*xspl5
16793 xi1 = xpas/288.*tspl11
16794 xint1 = xint1 +
xi1 16802 tspl2 = 19.*xspl0 + 75.*xspl1 + 50.*xspl2 + 50.*xspl3 + 75.*xspl4 + 19.*xspl5
16803 xi2 = xpas/288.*tspl2
16804 xint2 = xint2 +
xi2 16809 avrg(inc) = xint1/xint2 + xlcum
16810 xlcum = xlcum + xlcel
16818 function fcav(xc, nrc)
16819 implicit real *8(a-h, o-z)
16820 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
16829 do k = 1, npoint(nrc)
16836 a = (xc-xf(j-1))/(xf(j)-xf(j-1))
16837 b = (xf(j)-xc)/(xf(j)-xf(j-1))
16838 fcav = b*yf(j-1) + a*yf(j)
16851 function ta0(betr, nrc)
16852 implicit real *8(a-h, o-z)
16853 common /consta/vl, pi, xmat, rpel, qst
16854 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
16855 common /gaus13/h(13), t(13)
16856 common /gaus17/h1(17), t1(17)
16859 xk = fhc*2.*pi/(betr*vl)
16864 xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
16865 rfonc =
fcav(xc, nrc)
16866 ar = ar + t1(i)*rfonc*cos(xk*xc)
16875 function tta0(betr)
16876 implicit real *8(a-h, o-z)
16877 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
16878 common /consta/vl, pi, xmat, rpel, qst
16879 common /func/a(200), ylg, atte, ncel, nharm
16880 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
16881 common /rfield/ifield
16882 common /gaus13/h(13), t(13)
16898 xmin(i) = ylg*(i-1)/ncel
16904 if (xmin(ipas+1)==0 .or. ipas>(ncel+2))
return 16908 xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
16910 ar = ar + h(i)*rfonc*cos(xk*xc)
16924 function ta1(betr, nrc)
16925 implicit real *8(a-h, o-z)
16926 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
16927 common /consta/vl, pi, xmat, rpel, qst
16928 common /gaus13/h(13), t(13)
16929 common /gaus17/h1(17), t1(17)
16931 xk = fhc*2.*pi/(betr*vl)
16936 xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
16937 rfonc =
fcav(xc, nrc)
16938 ar = ar - t1(i)*xc*rfonc*sin(xk*xc)
16947 function tta1(betr)
16948 implicit real *8(a-h, o-z)
16949 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
16950 common /consta/vl, pi, xmat, rpel, qst
16951 common /func/a(200), ylg, atte, ncel, nharm
16952 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
16953 common /rfield/ifield
16954 common /gaus13/h(13), t(13)
16971 xmin(i) = ylg*(i-1)/ncel
16977 if (xmin(ipas+1)==0 .or. ipas>(ncel+2))
return 16981 xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
16983 ar = ar - h(i)*xc*rfonc*sin(xk*xc)
16996 function ta2(betr, nrc)
16997 implicit real *8(a-h, o-z)
16998 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
16999 common /consta/vl, pi, xmat, rpel, qst
17000 common /gaus13/h(13), t(13)
17001 common /gaus17/h1(17), t1(17)
17003 xk = fhc*2.*pi/(betr*vl)
17008 xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17009 rfonc =
fcav(xc, nrc)
17010 ar = ar - t1(i)*xc*xc*rfonc*cos(xk*xc)
17019 function tta2(betr)
17020 implicit real *8(a-h, o-z)
17021 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17022 common /consta/vl, pi, xmat, rpel, qst
17023 common /func/a(200), ylg, atte, ncel, nharm
17024 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17025 common /rfield/ifield
17026 common /gaus13/h(13), t(13)
17043 xmin(i) = ylg*(i-1)/ncel
17049 if (xmin(ipas+1)==0 .or. ipas>(ncel+2))
return 17053 xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17055 ar = ar - h(i)*xc*xc*rfonc*cos(xk*xc)
17068 function ta3(betr, nrc)
17069 implicit real *8(a-h, o-z)
17070 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17071 common /consta/vl, pi, xmat, rpel, qst
17072 common /gaus13/h(13), t(13)
17073 common /gaus17/h1(17), t1(17)
17075 xk = fhc*2.*pi/(betr*vl)
17080 xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17081 rfonc =
fcav(xc, nrc)
17082 ar = ar + t1(i)*xc*xc*xc*rfonc*sin(xk*xc)
17091 function tta3(betr)
17092 implicit real *8(a-h, o-z)
17093 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17094 common /consta/vl, pi, xmat, rpel, qst
17095 common /func/a(200), ylg, atte, ncel, nharm
17096 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17097 common /rfield/ifield
17098 common /gaus13/h(13), t(13)
17115 xmin(i) = ylg*(i-1)/ncel
17121 if (xmin(ipas+1)==0 .or. ipas>(ncel+2))
return 17125 xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17127 ar = ar + h(i)*xc*xc*xc*rfonc*sin(xk*xc)
17140 function ta4(betr, nrc)
17141 implicit real *8(a-h, o-z)
17142 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17143 common /consta/vl, pi, xmat, rpel, qst
17144 common /gaus13/h(13), t(13)
17145 common /gaus17/h1(17), t1(17)
17147 xk = fhc*2.*pi/(betr*vl)
17152 xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17153 rfonc =
fcav(xc, nrc)
17154 ar = ar + t1(i)*xc**4*rfonc*cos(xk*xc)
17163 function tta4(betr)
17164 implicit real *8(a-h, o-z)
17165 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17166 common /consta/vl, pi, xmat, rpel, qst
17167 common /func/a(200), ylg, atte, ncel, nharm
17168 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17169 common /rfield/ifield
17170 common /gaus13/h(13), t(13)
17187 xmin(i) = ylg*(i-1)/ncel
17193 if (xmin(ipas+1)==0 .or. ipas>(ncel+2))
return 17197 xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17199 ar = ar + h(i)*xc**4*rfonc*cos(xk*xc)
17212 function ta5(betr, nrc)
17213 implicit real *8(a-h, o-z)
17214 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17215 common /consta/vl, pi, xmat, rpel, qst
17216 common /gaus13/h(13), t(13)
17217 common /gaus17/h1(17), t1(17)
17219 xk = fhc*2.*pi/(betr*vl)
17224 xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17225 rfonc =
fcav(xc, nrc)
17226 ar = ar - t1(i)*xc**5*rfonc*sin(xk*xc)
17235 function tta5(betr)
17236 implicit real *8(a-h, o-z)
17237 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17238 common /consta/vl, pi, xmat, rpel, qst
17239 common /func/a(200), ylg, atte, ncel, nharm
17240 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17241 common /rfield/ifield
17242 common /gaus13/h(13), t(13)
17259 xmin(i) = ylg*(i-1)/ncel
17265 if (xmin(ipas+1)==0 .or. ipas>(ncel+2))
return 17269 xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17271 ar = ar - h(i)*xc**5*rfonc*sin(xk*xc)
17284 function sb0(betr, nrc)
17285 implicit real *8(a-h, o-z)
17286 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17287 common /consta/vl, pi, xmat, rpel, qst
17288 common /gaus13/h(13), t(13)
17289 common /gaus17/h1(17), t1(17)
17291 xk = fhc*2.*pi/(betr*vl)
17296 xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17297 rfonc =
fcav(xc, nrc)
17298 br = br + t1(i)*rfonc*sin(xk*xc)
17307 function tsb0(betr)
17308 implicit real *8(a-h, o-z)
17309 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17310 common /consta/vl, pi, xmat, rpel, qst
17311 common /func/a(200), ylg, atte, ncel, nharm
17312 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17313 common /rfield/ifield
17314 common /gaus13/h(13), t(13)
17331 xmin(i) = ylg*(i-1)/ncel
17337 if (xmin(ipas+1)==0 .or. ipas>(ncel+2))
return 17341 xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17343 br = br + h(i)*rfonc*sin(xk*xc)
17356 function sb1(betr, nrc)
17357 implicit real *8(a-h, o-z)
17358 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17359 common /consta/vl, pi, xmat, rpel, qst
17360 common /gaus13/h(13), t(13)
17361 common /gaus17/h1(17), t1(17)
17363 xk = fhc*2.*pi/(betr*vl)
17368 xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17369 rfonc =
fcav(xc, nrc)
17370 br = br + t1(i)*xc*rfonc*cos(xk*xc)
17379 function tsb1(betr)
17380 implicit real *8(a-h, o-z)
17381 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17382 common /consta/vl, pi, xmat, rpel, qst
17383 common /func/a(200), ylg, atte, ncel, nharm
17384 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17385 common /rfield/ifield
17386 common /gaus13/h(13), t(13)
17403 xmin(i) = ylg*(i-1)/ncel
17409 if (xmin(ipas+1)==0 .or. ipas>(ncel+2))
return 17413 xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17415 br = br + h(i)*xc*rfonc*cos(xk*xc)
17428 function sb2(betr, nrc)
17429 implicit real *8(a-h, o-z)
17430 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17431 common /consta/vl, pi, xmat, rpel, qst
17432 common /gaus13/h(13), t(13)
17433 common /gaus17/h1(17), t1(17)
17435 xk = fhc*2.*pi/(betr*vl)
17440 xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17441 rfonc =
fcav(xc, nrc)
17442 br = br - t1(i)*xc*xc*rfonc*sin(xk*xc)
17451 function tsb2(betr)
17452 implicit real *8(a-h, o-z)
17453 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17454 common /consta/vl, pi, xmat, rpel, qst
17455 common /func/a(200), ylg, atte, ncel, nharm
17456 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17457 common /rfield/ifield
17458 common /gaus13/h(13), t(13)
17475 xmin(i) = ylg*(i-1)/ncel
17481 if (xmin(ipas+1)==0 .or. ipas>(ncel+2))
return 17485 xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17487 br = br - h(i)*xc*xc*rfonc*sin(xk*xc)
17500 function sb3(betr, nrc)
17501 implicit real *8(a-h, o-z)
17502 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17503 common /consta/vl, pi, xmat, rpel, qst
17504 common /gaus13/h(13), t(13)
17505 common /gaus17/h1(17), t1(17)
17507 xk = fhc*2.*pi/(betr*vl)
17512 xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17513 rfonc =
fcav(xc, nrc)
17514 br = br - t1(i)*xc*xc*xc*rfonc*cos(xk*xc)
17523 function tsb3(betr)
17524 implicit real *8(a-h, o-z)
17525 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17526 common /consta/vl, pi, xmat, rpel, qst
17527 common /func/a(200), ylg, atte, ncel, nharm
17528 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17529 common /rfield/ifield
17530 common /gaus13/h(13), t(13)
17547 xmin(i) = ylg*(i-1)/ncel
17553 if (xmin(ipas+1)==0 .or. ipas>(ncel+2))
return 17557 xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17559 br = br - h(i)*xc*xc*xc*rfonc*cos(xk*xc)
17572 function sb4(betr, nrc)
17573 implicit real *8(a-h, o-z)
17574 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17575 common /consta/vl, pi, xmat, rpel, qst
17576 common /gaus13/h(13), t(13)
17577 common /gaus17/h1(17), t1(17)
17579 xk = fhc*2.*pi/(betr*vl)
17584 xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17585 rfonc =
fcav(xc, nrc)
17586 br = br + t1(i)*xc**4*rfonc*sin(xk*xc)
17595 function tsb4(betr)
17596 implicit real *8(a-h, o-z)
17597 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17598 common /consta/vl, pi, xmat, rpel, qst
17599 common /func/a(200), ylg, atte, ncel, nharm
17600 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17601 common /rfield/ifield
17602 common /gaus13/h(13), t(13)
17619 xmin(i) = ylg*(i-1)/ncel
17625 if (xmin(ipas+1)==0 .or. ipas>(ncel+2))
return 17629 xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17631 br = br + h(i)*xc**4*rfonc*sin(xk*xc)
17644 function sb5(betr, nrc)
17645 implicit real *8(a-h, o-z)
17646 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17647 common /consta/vl, pi, xmat, rpel, qst
17648 common /gaus13/h(13), t(13)
17649 common /gaus17/h1(17), t1(17)
17651 xk = fhc*2.*pi/(betr*vl)
17656 xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17657 rfonc =
fcav(xc, nrc)
17658 br = br + t1(i)*xc**5*rfonc*cos(xk*xc)
17667 function tsb5(betr)
17668 implicit real *8(a-h, o-z)
17669 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17670 common /consta/vl, pi, xmat, rpel, qst
17671 common /func/a(200), ylg, atte, ncel, nharm
17672 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17673 common /rfield/ifield
17674 common /gaus13/h(13), t(13)
17691 xmin(i) = ylg*(i-1)/ncel
17697 if (xmin(ipas+1)==0 .or. ipas>(ncel+2))
return 17701 xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17703 br = br + h(i)*xc**5*rfonc*cos(xk*xc)
17718 implicit real *8(a-h, o-z)
17719 common /consta/vl, pi, xmat, rpel, qst
17720 common /func/a(200), ylg, atte, ncel, nharm
17721 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17735 implicit real *8(a-h, o-z)
17736 common /func/a(200), ylg, atte, ncel, nharm
17737 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17738 common /tapes/in, ifile, meta
17739 common /consta/vl, pi, xmat, rpel, qst
17740 common /rfield/ifield
17741 common /mode/eflvl, rflvl
17749 read (in, *) ylg, fh, atte, ncel
17751 read (in, *)(a(i), i=1, nharm)
17752 write (16, 100) ncel, ylg, fh, atte
17753 100
format (
' number of cells in the cavity: ', i3, /,
' field length: ', e12.5,
'cm', /,
' freq. ', e12.5,
' Hertz', &
17754 ' field factor ', e12.5)
17755 write (16, *)
' number of harmonics: ', nharm
17756 write (16, 200)(a(i), i=1, nharm)
17757 200
format (3(2x,e12.5))
17765 open (18, file=
'chemtr.txt', status=
'unknown')
17774 write (18, 99) zx/100., ff
17775 99
format (3(2x,e12.5))
17777 if (zx<ylg)
go to 98
17781 end subroutine rharm 17788 implicit real *8(a-h, o-z)
17789 common /dplt/zdeb, zfin, ywmax, ypmax, rmsn
17790 common /tapes/in, ifile, meta
17807 implicit real *8(a-h, o-z)
17808 dimension xx(3000), yy(3000)
17812 character *80 car, text
17813 common /dplt/zdeb, zfin, ywmax, ypmax, rmsn
17814 common /pltprf/sprfy(3000), sprfz(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
17815 common /tapes/in, ifile, meta
17818 read (in, 69) car(1:80)
17821 read (in, *) zdeb, zfin
17822 read (in, *) xxmax, xymax, ywmax, ypmax
17826 if (zfin>sprfl(iprf)) zfin = sprfl(iprf)
17827 write (16, *)
' ******* PROFIL ***************** ' 17828 write (16, *)
' IPRF ZFIN ', iprf, zfin
17830 if ((zdeb>sprfl(i-1)) .and. (zdeb<=sprfl(i))) ideb = i
17831 if ((zfin>=sprfl(i-1)) .and. (zfin<sprfl(i))) ifin = i - 1
17833 if (xxmax<=0.)
then 17836 if (0.5*sprfy(i)*rmsn>xxmax) xxmax = 0.5*sprfy(i)*rmsn
17839 if (xymax<=0.)
then 17842 if (0.5*sprfz(i)*rmsn>xymax) xymax = 0.5*sprfz(i)*rmsn
17850 text =
'X and Y envelopes ' 17851 text(21:80) = car(1:60)
17852 write (66, *) igrtyp
17858 write (16, *)
' XMAX YMAX ', xxmax, xymax
17859 write (66, *) xx(1), xx(2), yy(1), yy(2)
17865 xx(icnt) = sprfl(i)
17866 yy(icnt) = 0.5*sprfy(i)*rmsn
17871 write (66, *) xx(i), yy(i)
17876 xx(icnt) = sprfl(i)
17877 yy(icnt) = -0.5*sprfz(i)*rmsn
17882 write (66, *) xx(i), yy(i)
17892 implicit real *8(a-h, o-z)
17893 dimension xx(3000), yy(3000)
17894 character *80 car, text
17896 common /dplt/zdeb, zfin, ywmax, ypmax, rmsn
17897 common /pltprf/sprfy(3000), sprfz(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
17902 if ((zdeb>sprfl(i-1)) .and. (zdeb<=sprfl(i))) ideb = i
17903 if ((zfin>=sprfl(i-1)) .and. (zfin<sprfl(i))) ifin = i - 1
17905 xxmax = ywmax/1000.
17907 if (xxmax<=0.)
then 17910 if (0.5*sprfw(i)*rmsn>xxmax) xxmax = 0.5*sprfw(i)*rmsn
17913 if (xymax<=0.)
then 17916 if (0.5*sprfp(i)*rmsn>xymax) xymax = 0.5*sprfp(i)*rmsn
17924 text =
'dW/W envelope ' 17925 text(21:80) = car(1:60)
17926 write (66, *) igrtyp
17931 yy(2) = xxmax*1000.
17932 write (66, *) xx(1), xx(2), yy(1), yy(2)
17936 xx(icnt) = sprfl(i)
17937 yy(icnt) = 0.5*sprfw(i)*1000.*rmsn
17942 write (66, *) xx(i), yy(i)
17949 text =
'dPHI envelope ' 17950 text(21:80) = car(1:60)
17951 write (66, *) igrtyp
17958 write (16, *)
' dW/WMAX dPhiMAX ', xxmax, xymax
17959 write (66, *) xx(1), xx(2), yy(1), yy(2)
17963 xx(icnt) = sprfl(i)
17964 yy(icnt) = 0.5*sprfp(i)*rmsn
17969 write (66, *) xx(i), yy(i)
17978 function slope(n, xv)
17979 implicit real *8(a-h, o-z)
17980 common /spl/x(4000), y(4000), s(5000), p(5000), q(5000)
17984 if (xtvi>0.)
go to 4
17985 if (xtvi<0.)
go to 2
17986 if (xtvi==0.00)
go to 3
17990 avx = x(i+1) - x(i)
17991 slope = s(i+1)*avx/3. + s(i)*avx/6. + (y(i+1)-y(i))/avx
17996 avx = x(i+1) - x(i)
17997 slope = -(s(i)*ddx*ddx)/(2.*avx) + (s(i+1)*dgx*dgx)/(2.*avx) + ((y(i+1)-y(i))/avx) - (avx*(s(i+1)-s(i))/6.)
18005 implicit real *8(a-h, o-z)
18006 common /spl/x(4000), y(4000), s(5000), p(5000), q(5000)
18011 spline = y(1) + ((y(2)-y(1))/(x(2)-x(1))-s(2)*(x(2)-x(1))/6.)*(xv-x(1))
18014 if (xtv1==0.00)
then 18020 if (xtvn==0.00)
then 18025 spline = y(n) + ((y(n)-y(n-1))/(x(n)-x(n-1))+s(n-1)*(x(n)-x(n-1))/6.)*(xv-x(n))
18031 if (xtvi>0.)
go to 11
18032 if (xtvi<0.)
go to 2
18033 if (xtvi==0.)
go to 3
18041 avx = x(i+1) - x(i)
18042 spline = s(i)*ddx**3/(6.*avx) + s(i+1)*dgx**3/(6.*avx) + (y(i+1)/avx-s(i+1)*avx/6.)*dgx + &
18043 (y(i)/avx-s(i)*avx/6.)*ddx
18053 implicit real *8(a-h, o-z)
18054 common /spl/x(4000), y(4000), s(5000), p(5000), q(5000)
18056 avxn = x(n) - x(n-1)
18057 avvxn = x(n-1) - x(n-2)
18058 avyn = y(n) - y(n-1)
18059 avvyn = y(n-1) - y(n-2)
18060 f = avxn - (avvxn**2)/avxn
18064 p(n-1) = (-2.*avxn-3.*avvxn-avvxn**2/avxn)/f
18065 q(n-1) = 6.*(avyn/avxn-avvyn/avvxn)/f
18070 avx = x(i+1) - x(i)
18071 avvx = x(i+2) - x(i+1)
18072 avy = y(i+1) - y(i)
18073 avvy = y(i+2) - y(i+1)
18074 d = 2.*(avx+avvx) + avvx*p(i+1)
18076 q(i) = (6.*(avvy/avvx-avy/avx)-avvx*q(i+1))/d
18079 avvx1 = x(3) - x(2)
18080 g1 = (avvx1/avx1) + 1. - p(2) - (q(2)/q(1))
18081 g2 = (avvx1/(avx1*p(1))) - (avvx1/avx1) - 1. + p(2)
18082 s(1) = (q(1)*g1)/(p(1)*g2)
18084 s(i+1) = p(i)*s(i) + q(i)
18093 implicit real *8(a-h, o-z)
18094 common /spff/x(400), y(400), s(500), p(500), q(500)
18096 avxn = x(n) - x(n-1)
18097 avvxn = x(n-1) - x(n-2)
18098 avyn = y(n) - y(n-1)
18099 avvyn = y(n-1) - y(n-2)
18100 f = avxn - (avvxn**2)/avxn
18104 p(n-1) = (-2.*avxn-3.*avvxn-avvxn**2/avxn)/f
18105 q(n-1) = 6.*(avyn/avxn-avvyn/avvxn)/f
18110 avx = x(i+1) - x(i)
18111 avvx = x(i+2) - x(i+1)
18112 avy = y(i+1) - y(i)
18113 avvy = y(i+2) - y(i+1)
18114 d = 2.*(avx+avvx) + avvx*p(i+1)
18116 q(i) = (6.*(avvy/avvx-avy/avx)-avvx*q(i+1))/d
18119 avvx1 = x(3) - x(2)
18120 g1 = (avvx1/avx1) + 1. - p(2) - (q(2)/q(1))
18121 g2 = (avvx1/(avx1*p(1))) - (avvx1/avx1) - 1. + p(2)
18122 s(1) = (q(1)*g1)/(p(1)*g2)
18124 s(i+1) = p(i)*s(i) + q(i)
18133 implicit real *8(a-h, o-z)
18134 common /spff/x(400), y(400), s(500), p(500), q(500)
18139 splinf = y(1) + ((y(2)-y(1))/(x(2)-x(1))-s(2)*(x(2)-x(1))/6.)*(xv-x(1))
18142 if (xtv1==0.00)
then 18148 if (xtvn==0.00)
then 18153 splinf = y(n) + ((y(n)-y(n-1))/(x(n)-x(n-1))+s(n-1)*(x(n)-x(n-1))/6.)*(xv-x(n))
18159 if (xtvi>0.)
go to 11
18160 if (xtvi<0.)
go to 2
18161 if (xtvi==0.)
go to 3
18169 avx = x(i+1) - x(i)
18170 splinf = s(i)*ddx**3/(6.*avx) + s(i+1)*dgx**3/(6.*avx) + (y(i+1)/avx-s(i+1)*avx/6.)*dgx + &
18171 (y(i)/avx-s(i)*avx/6.)*ddx
18180 function slopf(n, xv)
18181 implicit real *8(a-h, o-z)
18182 common /spff/x(400), y(400), s(500), p(500), q(500)
18186 if (xtvi>0.)
go to 4
18187 if (xtvi<0.)
go to 2
18188 if (xtvi==0.00)
go to 3
18192 avx = x(i+1) - x(i)
18193 slopf = s(i+1)*avx/3. + s(i)*avx/6. + (y(i+1)-y(i))/avx
18198 avx = x(i+1) - x(i)
18199 slopf = -(s(i)*ddx*ddx)/(2.*avx) + (s(i+1)*dgx*dgx)/(2.*avx) + ((y(i+1)-y(i))/avx) - (avx*(s(i+1)-s(i))/6.)
18209 subroutine area(init)
18210 implicit real *8(a-h, o-z)
18211 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
18212 common /faisc/f(10, iptsz), imax, ngood
18213 common /consta/vl, pi, xmat, rpel, qst
18214 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
18215 common /part/xc(iptsz), yc(iptsz), zc(iptsz)
18216 common /tapes/in, ifile, meta
18217 common /zones/frms(6), nzone
18218 dimension inzonn(6)
18228 read (in, *) ityp, nzone
18229 write (16, *)
'Number of zones selected:', nzone
18231 write (16, *)
'Number of zones is greater than 5 ', nzone
18238 read (in, *)(frms(i), i=2, nzone)
18239 frms(nzone+1) = 100.
18241 write (16, *)
'Zone: ', i,
' lower limit: ', frms(i),
' upper limit:', frms(i+1)
18244 read (in, *) frms(2)
18250 trmoy = trmoy + f(6, i)
18252 trmoy = trmoy/float(ngood)
18259 gnp = f(7, np)/xmat
18260 vnp = vl*sqrt(1.-1./(gnp*gnp))
18261 zc(np) = (trmoy-f(6,np))*vnp
18263 f3 = f(3, np)*1.e-03
18264 f5 = f(5, np)*1.e-03
18266 xc(np) = (f(2,np)+zc(np)*f3)/100.
18267 yc(np) = (f(4,np)+zc(np)*f5)/100.
18268 zc(np) = zc(np)/100.
18270 xbar = xbar + xc(np)
18271 ybar = ybar + yc(np)
18272 zbar = zbar + zc(np)
18279 xc(np) = xc(np) - xbar
18280 yc(np) = yc(np) - ybar
18281 zc(np) = zc(np) - zbar
18291 xsqsum = xsqsum + xcj*xcj
18292 ysqsum = ysqsum + ycj*ycj
18293 zsqsum = zsqsum + zcj*zcj
18295 xrmsz = xsqsum/float(ngood)
18296 yrmsz = ysqsum/float(ngood)
18297 zrmsz = zsqsum/float(ngood)
18298 xrmsz = sqrt(xrmsz)
18299 yrmsz = sqrt(yrmsz)
18300 zrmsz = sqrt(zrmsz)
18310 rxyz = sqrt((xcp*xcp+ycp*ycp+zcp*zcp)/3.)
18311 if (rxyz<frms(i+1) .and. rxyz>=frms(i))
then 18312 inzonn(i) = inzonn(i) + 1
18313 if (init==1) f(10, j) = frms(i+1)
18315 if (f(10,j)==100. .and. init==1) f(10, j) = 0.
18318 write (16, *) inzonn(i),
' particles initially in zone ', i
18320 write (16, *) inzonn(i),
' particles in zone ', i
18331 rxyz = sqrt((xcp*xcp+ycp*ycp)/2.)
18332 if (rxyz<frms(i+1) .and. rxyz>=frms(i))
then 18333 inzonn(i) = inzonn(i) + 1
18334 if (init==1) f(10, j) = frms(i+1)
18336 if (f(10,j)==100. .and. init==1) f(10, j) = 0.
18339 write (16, *) inzonn(i),
' particles initially in zone ', i
18341 write (16, *) inzonn(i),
' particles in zone ', i
18347 end subroutine area 18353 implicit real *8(a-h, o-z)
18354 parameter(iptsz=100002)
18355 common /faisc/f(10, iptsz), imax, ngood
18356 common /consta/vl, pi, xmat, rpel, qst
18357 common /tapes/in, ifile, meta
18358 common /dyn/tref, vref
18359 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
18360 common /part/xc(iptsz), yc(iptsz), zc(iptsz)
18361 common /hist/xpos(200), xn(200), ypos(200), yn(200), zpos(200), zn(200), ixt, iyt, izt
18362 common /hist1/xps(200), xpn(200), yps(200), ypn(200), zps(200), zpn(200), ixpt, iypt, izpt
18371 trmoy = trmoy + f(6, i)
18372 wcg = wcg + f(7, i)
18373 xcg = xcg + f(2, i)
18374 ycg = ycg + f(4, i)
18376 trmoy = trmoy/float(ngood)
18377 wcg = wcg/float(ngood)
18378 xcg = xcg/float(ngood)
18379 ycg = ycg/float(ngood)
18387 gnp = f(7, np)/xmat
18388 vnp = vl*sqrt(1.-1./(gnp*gnp))
18389 zc(np) = (trmoy-f(6,np))*vnp/100.
18390 xc(np) = (f(2,np)-xcg)/100.
18391 xb2z = xb2z + zc(np)*zc(np)
18392 xb2x = xb2x + xc(np)*xc(np)
18393 xbxz = xbxz + zc(np)*xc(np)
18396 xb2z = xb2z/float(imaxx)
18397 xb2x = xb2x/float(imaxx)
18398 xbxz = xbxz/float(imaxx)
18399 apl = atan(-2.*xbxz/(xb2x-xb2z))/2.
18407 gnp = f(7, np)/xmat
18408 vnp = vl*sqrt(1.-1./(gnp*gnp))
18409 znp = (trmoy-f(6,np))*vnp
18411 zc(np) = znp*cos(apl) + xnp*sin(apl)
18412 xnp = xnp*cos(apl) - znp*sin(apl)
18414 f3 = f(3, np)*1.e-03
18415 f5 = f(5, np)*1.e-03
18417 xc(np) = (xnp+zc(np)*f3)/100.
18418 yc(np) = (f(4,np)+zc(np)*f5)/100.
18419 zc(np) = zc(np)/100.
18421 xbar = xbar + xc(np)
18422 ybar = ybar + yc(np)
18423 zbar = zbar + zc(np)
18430 xc(np) = xc(np) - xbar
18431 yc(np) = yc(np) - ybar
18432 zc(np) = zc(np) - zbar
18439 xsqsum = xsqsum + xc(j)*xc(j)
18440 ysqsum = ysqsum + yc(j)*yc(j)
18441 zsqsum = zsqsum + zc(j)*zc(j)
18443 xrmsz = xsqsum/float(ngood)
18444 yrmsz = ysqsum/float(ngood)
18445 zrmsz = zsqsum/float(ngood)
18446 xrmsz = sqrt(xrmsz)
18447 yrmsz = sqrt(yrmsz)
18448 zrmsz = sqrt(zrmsz)
18451 xc(j) = xc(j)/xrmsz
18452 yc(j) = yc(j)/yrmsz
18453 zc(j) = zc(j)/zrmsz
18463 if ((abs(xc(i))<=fract) .and. (abs(yc(i))<=fract) .and. (abs(zc(i))<=fract))
then 18464 if (xinf>xc(i)) xinf = xc(i)
18465 if (yinf>yc(i)) yinf = yc(i)
18466 if (zinf>zc(i)) zinf = zc(i)
18474 if ((abs(xc(i))<=fract) .and. (abs(yc(i))<=fract) .and. (abs(zc(i))<=fract))
then 18475 if (xsup<xc(i)) xsup = xc(i)
18476 if (ysup<yc(i)) ysup = yc(i)
18477 if (zsup<zc(i)) zsup = zc(i)
18497 if (x1>xsup+stepx)
go to 160
18499 if (xc(i)>x0 .and. xc(i)<=x1) xn(j) = xn(j) + 1.
18501 xtot = xtot + xn(j)
18502 xpos(j) = x0 + stepx/2.
18514 if (xnor<xn(i)) xnor = xn(i)
18532 if (y1>ysup+stepy)
go to 161
18534 if (yc(i)>y0 .and. yc(i)<=y1) yn(j) = yn(j) + 1.
18536 ytot = ytot + yn(j)
18537 ypos(j) = y0 + stepy/2.
18550 if (ynor<yn(i)) ynor = yn(i)
18569 if (z1>zsup+2.*stepz)
go to 162
18571 if (zc(i)>z0 .and. zc(i)<=z1) zn(j) = zn(j) + 1.
18573 ztot = ztot + zn(j)
18574 zpos(j) = z0 + stepz/2.
18588 if (znor<zn(i)) znor = zn(i)
18596 zpinf = f(6, 1) - trmoy
18601 f6 = f(6, i) - trmoy
18602 if (xpinf>f3) xpinf = f3
18603 if (ypinf>f5) ypinf = f5
18604 if (zpinf>f6) zpinf = f6
18613 f6 = f(6, i) - trmoy
18614 if (xpsup<f3) xpsup = f3
18615 if (ypsup<f5) ypsup = f5
18616 if (zpsup<f6) zpsup = f6
18619 paxp = (xpsup-xpinf)
18620 payp = (ypsup-ypinf)
18621 pazp = (zpsup-zpinf)
18629 f6 = f(6, i) - trmoy
18630 xpsum = xpsum + f3*f3
18631 ypsum = ypsum + f5*f5
18632 zpsum = zpsum + f6*f6
18634 xpsum = xpsum/float(ngood)
18635 ypsum = ypsum/float(ngood)
18636 zpsum = zpsum/float(ngood)
18637 xpsum = sqrt(xpsum)
18638 ypsum = sqrt(ypsum)
18639 zpsum = sqrt(zpsum)
18651 if (xp1>xpsup+stpx)
go to 260
18653 if (f(3,i)>xp0 .and. f(3,i)<=xp1) xpn(j) = xpn(j) + 1.
18655 xps(j) = xp0 + stpx/2.
18667 if (xnor<xpn(i)) xnor = xpn(i)
18670 xpn(i) = xpn(i)/xnor
18671 xps(i) = xps(i)/xpsum
18684 if (yp1>ypsup+stpy)
go to 261
18686 if (f(5,i)>yp0 .and. f(5,i)<=yp1) ypn(j) = ypn(j) + 1.
18688 yps(j) = yp0 + stpy/2.
18701 if (ynor<ypn(i)) ynor = ypn(i)
18704 ypn(i) = ypn(i)/ynor
18705 yps(i) = yps(i)/ypsum
18719 if (zp1>zpsup+2.*stpz)
go to 262
18721 f6 = f(6, i) - trmoy
18722 if (f6>zp0 .and. f6<=zp1) zpn(j) = zpn(j) + 1.
18724 zps(j) = zp0 + stpz/2.
18736 if (zpnor<zpn(i)) zpnor = zpn(i)
18739 zpn(i) = zpn(i)/zpnor
18740 zps(i) = zps(i)/zpsum
18772 implicit real *8(a-h, o-z)
18773 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
18774 common /consta/vl, pi, xmat, rpel, qst
18775 common /faisc/f(10, iptsz), imax, ngood
18776 common /speda/dave, idave
18777 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
18778 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
18779 common /etcom/cog(8), exten(17), fd(iptsz)
18780 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
18781 common /cptemit/xltot(maxcell1), nbemit
18782 common /poro/irot1, irot2
18783 logical irot1, irot2
18784 common /secdr/iseor
18785 common /itvole/itvol, imamin
18786 common /dyni/vrefi, trefi, fhinit, acpt
18788 common /shortl/davprt
18790 logical dave, chasit, ichaes, itvol, imamin, ityq
18791 character *80 davprt(maxcell1)
18794 3334
format (
'*****************************************************')
18797 write (12, *)
' Energies are in [MeV], phases in [deg]',
' lengths in [mm] ,tof in [deg]' 18798 write (12, *)
' ** For lenses followed by :',
' Cummulative length, element type, length ' 18800 write (12, *)
' ** For emit followed by' 18801 write (12, *)
' * Line 1:',
' Particle reference: beta, energy, tof ', &
18802 ' COG: energy, tof, energy offset, tof offset' 18803 write (12, *)
' * Line 2:',
' COG coordinates for x xp y yp (mm and mrad)' 18804 write (12, *)
' * Line 3:',
' alpha-x beta-x(mm/mrad) alpha-y beta-y(mm/mrad)',
' alpha-z beta-z(ns/keV)' 18805 write (12, *)
' * Line 4:',
' alpha-z beta-z(deg/keV) emit-z(non norm.,keV.deg) f(MHz)' 18806 write (12, *)
' * Line 5:',
' dPHI(deg) dW(keV) r12 long. emittance',
' (keV.ns) particles left' 18807 write (12, *)
' * Line 6:',
' x(mm) xp(mrad) r12 hor. emittance',
' (norm & non norm, mm.mrad)' 18808 write (12, *)
' * Line 7:',
' y(mm) yp(mrad) r12 vert. emittance',
' (norm & non norm, mm.mrad)' 18811 write (12, *)
' Simulation with ', imax,
' particles' 18813 write (12, *)
' Second order transport matrix ' 18815 write (12, *)
' First order transport matrix ' 18818 write (12, *)
' Beam intensity ', beamc,
' mA' 18819 if (iscsp==1)
write (12, *)
' Space charge calculations with HERSC ' 18820 if (iscsp==2)
write (12, *)
' Space charge calculations with SCHERM ' 18821 if (iscsp==3 .or. iscsp==4)
write (12, *)
' Space charge calculations with SCHEFF ' 18822 if (sce10==1)
write (12, *) &
18823 'Space charge calculated for all relevant elements, but not at drifts' 18824 if (sce10==2)
write (12, *)
'Space charge calculated for accelerating elements only' 18825 if (sce10==3)
write (12, *)
'Space charge calculated for all relevant elements' 18827 if (itvol)
write (12, *)
' TOF is operational in accelerating elements ' 18828 if (imamin)
write (12, *)
'Phase adjustments for accelerating elements active' 18834 if (davprt(i)/=
'')
write (12,
'(A)') davprt(i)
18835 if (iitem(i)==1)
then 18837 n = int(dav1(i,25)+.5)
18838 if (itvol .and. imamin)
then 18839 write (12, 1000) dav1(i, 24), n, dav1(i, 1), dav1(i, 38), dav1(i, 39)
18840 1000
format (f9.2,
' mm Cavity ', i3,
' length ', f7.2,
' mm', /,
' phase offset: before adjustement ', e12.5, &
18841 ' deg',
' after adjustement ', e14.7,
' deg')
18843 write (12, 2789) dav1(i, 24), n, dav1(i, 1), dav1(i, 38)
18845 2789
format (f9.2,
' mm Cavity ', i3,
' length ', f7.2,
' mm',
' phase offset: ', e12.5,
' deg')
18848 if (iitem(i)==2)
then 18850 write (12, 1010) dav1(i, 4), dav1(i, 1), dav1(i, 7), dav1(i, 2), dav1(i, 3), dav1(i, 5), dav1(i, 6), &
18852 1010
format (f9.2,
' mm Quadrupole: length = ', e12.5,
' mm',
' aperture radius = ', e12.5,
' mm', /, &
18853 ' field = ', e12.5,
' kG K2 = ', e12.5,
' cm-2 gradient = ', e12.5,
' kG/cm', /,
' momentum = ', e12.5, &
18854 ' kG.cm particles left ', f7.0)
18858 if (iitem(i)==3)
then 18861 305
format (
'********** beam (emit card) ',
'**********')
18869 write (12, 1001)(dav1(i,j), j=3, 9)
18870 1001
format (2x, f7.5, 4(1x,e14.7), 2(2x,e12.5),
' MeV-deg')
18871 write (12, 2003)(dav1(i,j), j=31, 34)
18872 2003
format (4(2x,f7.3),
' mm and mrad ')
18878 emz = dav1(i, 12)*1000.*(180./pi)
18880 if (emz>1.e-10) betz = dav1(i, 10)*dav1(i, 10)/emz
18881 dez = dav1(i, 11)*1000.
18883 if (emz>1.e-10) gamz = dez*dez/emz
18885 if (betz*gamz>=1.) alpz = sqrt(betz*gamz-1.)
18886 if (dav1(i,23)>0.) alpz = -alpz
18889 emzz = 1.e12*dav1(i, 12)/fh
18890 dphizz = 1.e09*dav1(i, 10)/fh*(pi/180.)
18892 if (emzz>1.e-10) betzz = dphizz*dphizz/emzz
18894 if (emzz>1.e-10) gamzz = dez*dez/emzz
18896 if (betzz*gamzz>=1.) alpzz = sqrt(betzz*gamzz-1.)
18897 if (dav1(i,23)>0.) alpzz = -alpzz
18903 if (emx>1e-10) betx = dav1(i, 13)*dav1(i, 13)/emx
18905 if (emx>1e-10) gamx = dav1(i, 14)*dav1(i, 14)/emx
18907 if (betx*gamx>=1.) alpx = sqrt(betx*gamx-1.)
18908 if (dav1(i,15)>0.) alpx = -alpx
18914 if (emy>1e-10) bety = dav1(i, 18)*dav1(i, 18)/emy
18916 if (emy>1e-10) gamy = dav1(i, 19)*dav1(i, 19)/emy
18918 if (bety*gamy>=1.) alpy = sqrt(bety*gamy-1.)
18919 if (dav1(i,20)>0.) alpy = -alpy
18922 write (12, 3213) alpx, betx, alpy, bety, alpzz, betzz
18923 3213
format (3(2x,e12.5,2x,e12.5), 2x, e12.5)
18925 write (12, 597) alpz, betz, emz, fh/(2.*pi*1.e6)
18926 597
format (2x, f8.4, 2x, e13.6, 2x, e13.6,
' keV.deg', 2x, f8.3,
' MHz')
18927 if (emzz>1000.)
then 18929 write (12, 6332) dav1(i, 10), dez, dav1(i, 23), emzz/1000., dav1(i, 30)
18930 6332
format (2x, f7.3, 1x, f10.2, 2x, f8.4, 3x, f8.3,
' ns.MeV ', f7.0,
' particles left')
18933 write (12, 1002) dav1(i, 10), dez, dav1(i, 23), emzz, dav1(i, 30)
18934 1002
format (2x, e12.5, 2x, f7.2, 2x, f8.4, 2x, f7.3,
' ns.keV ', f7.0,
' particles left')
18936 write (12, 1003)(dav1(i,j), j=13, 22)
18937 1003
format (2(2x,f7.3,3x,f8.3,2x,f8.4,2x,e12.5,
' mm.mrad (norm)',2x,f7.3,
' (non norm)',/))
18939 if (dav1(i,26)==1.)
then 18940 write (12, 8333)(dav2(i,j), j=31, 33)
18941 8333
format (
'********** With chase', 3(1x,f6.4),
' **********')
18942 write (12, 1001)(dav1(i,j), j=3, 9)
18943 write (12, 2003)(dav2(i,j), j=26, 29)
18948 emz = dav2(i, 12)*1000.*(180./pi)
18950 if (emz>1.e-10) betz = dav2(i, 10)*dav2(i, 10)/emz
18951 dez = dav2(i, 11)*1000.
18953 if (emz>1.e-10) gamz = dez*dez/emz
18955 if (betz*gamz>=1.) alpz = sqrt(betz*gamz-1.)
18956 if (dav2(i,23)>0.) alpz = -alpz
18959 emzz = 1.e12*dav2(i, 12)/fh
18960 dphizz = 1.e09*dav2(i, 10)/fh*(pi/180.)
18962 if (emzz>1.e-10) betzz = dphizz*dphizz/emzz
18964 if (emzz>1.e-10) gamzz = dez*dez/emzz
18966 if (betzz*gamzz>=1.) alpzz = sqrt(betzz*gamzz-1.)
18967 if (dav2(i,23)>0.) alpzz = -alpzz
18973 if (emx>1e-10) betx = dav2(i, 13)*dav2(i, 13)/emx
18975 if (emx>1e-10) gamx = dav2(i, 14)*dav2(i, 14)/emx
18977 if (betx*gamx>=1.) alpx = sqrt(betx*gamx-1.)
18978 if (dav2(i,15)>0.) alpx = -alpx
18984 if (emy>1e-10) bety = dav2(i, 18)*dav2(i, 18)/emy
18986 if (emy>1e-10) gamy = dav2(i, 19)*dav2(i, 19)/emy
18988 if (bety*gamy>=1.) alpy = sqrt(bety*gamy-1.)
18989 if (dav2(i,20)>0.) alpy = -alpy
18992 write (12, 3213) alpx, betx, alpy, bety, alpzz, betzz
18993 if (emzz>1000.)
then 18995 write (12, 6332) dav2(i, 10), dez, dav2(i, 23), emzz/1000., dav2(i, 30)
18998 write (12, 1002) dav2(i, 10), dez, dav2(i, 23), emzz, dav2(i, 30)
19006 write (12, 1003)(dav2(i,j), j=13, 22)
19010 if (iitem(i)==4)
then 19012 write (12, 1025) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 3)
19013 1025
format (f9.2,
' mm bending magnet: central trajectory: ', f8.2,
' mm', /,
' bend angle: ', f7.3, &
19014 ' deg bending radius: ', e12.5,
' mm')
19015 write (12, 1029) dav1(i, 16), dav1(i, 14), dav1(i, 15)
19016 1029
format (
' field: ', f7.3,
' T n: ', f8.3,
' beta: ', f8.3)
19017 write (12, 1026) dav1(i, 6), dav1(i, 9), dav1(i, 7), dav1(i, 8), dav1(i, 5)
19018 1026
format (
' *Entrance ', /,
' pole-face rotation:', f8.3,
' deg curvature: ', f8.3,
' mm', /, &
19019 ' fringe field corrections: K1 ', f8.3,
' K2 ', f8.3, /,
' vertical half-aperture: ', f8.3,
' mm')
19020 write (12, 1027) dav1(i, 10), dav1(i, 13), dav1(i, 11), dav1(i, 12), dav1(i, 17)
19021 1027
format (
' *Exit ', /,
' pole-face rotation :', f8.3,
' deg curvature: ', f8.3,
' mm', /, &
19022 ' fringe field correction: K1 ', f7.3,
' K2 ', f7.3, /,
' vertical half-aperture: ', f8.3,
' mm')
19023 write (12, 1028) dav1(i, 37)
19024 1028
format (
' particles left ', f7.0)
19027 if (iitem(i)==5)
then 19029 write (12, 5010) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 3), dav1(i, 5), dav1(i, 36)
19030 5010
format (f9.2,
' mm Solenoid: length = ', f8.3,
' mm',
' field = ', e12.5,
' kG K = ', e12.5,
' cm-1', /, &
19031 ' momentum = ', e12.5,
' kG.cm particles left ', f7.0)
19034 if (iitem(i)==6)
then 19037 303
format (
'********** INITIAL BEAM **********')
19038 write (12, 2003)(dav1(i,j), j=31, 34)
19042 emz = dav1(i, 12)*1000.*(180./pi)
19044 if (emz>1.e-10) betz = dav1(i, 10)*dav1(i, 10)/emz
19045 dez = dav1(i, 11)*1000.
19047 if (emz>1.e-10) gamz = dez*dez/emz
19049 if (betz*gamz>=1.) alpz = sqrt(betz*gamz-1.)
19052 emzz = 1.e12*dav1(i, 12)/fhinit
19053 dphizz = 1.e09*dav1(i, 10)/fhinit*(pi/180.)
19055 if (emzz>1.e-10) betzz = dphizz*dphizz/emzz
19057 if (emzz>1.e-10) gamzz = dez*dez/emzz
19059 if (betzz*gamzz>=1.) alpzz = sqrt(betzz*gamzz-1.)
19065 if (emx>1e-10) betx = dav1(i, 13)*dav1(i, 13)/emx
19067 if (emx>1e-10) gamx = dav1(i, 14)*dav1(i, 14)/emx
19069 if (betx*gamx>=1.) alpx = sqrt(betx*gamx-1.)
19075 if (emy>1e-10) bety = dav1(i, 18)*dav1(i, 18)/emy
19077 if (emy>1e-10) gamy = dav1(i, 19)*dav1(i, 19)/emy
19079 if (bety*gamy>=1.) alpy = sqrt(bety*gamy-1.)
19082 write (12, 3213) alpx, betx, alpy, bety, alpzz, betzz
19085 write (12, 597) alpz, betz, emz, fh/(2.*pi*1.e6)
19086 if (emzz>1000.)
then 19088 write (12, 6332) dav1(i, 10), dez, dav1(i, 23), emzz/1000., dav1(i, 30)
19091 write (12, 1002) dav1(i, 10), dez, dav1(i, 23), emzz, dav1(i, 30)
19093 write (12, 1003)(dav1(i,j), j=13, 22)
19096 304
format (
'********** With chase ',
'**********')
19097 write (12, 2003)(dav2(i,j), j=26, 29)
19101 emz = dav2(i, 12)*1000.*(180./pi)
19103 if (emz>1.e-10) betz = dav2(i, 10)*dav2(i, 10)/emz
19104 dez = dav2(i, 11)*1000.
19106 if (emz>1.e-10) gamz = dez*dez/emz
19108 if (betz*gamz>=1.) alpz = sqrt(betz*gamz-1.)
19111 emzz = 1.e12*dav2(i, 12)/fh
19112 dphizz = 1.e09*dav2(i, 10)/fh*(pi/180.)
19114 if (emzz>1.e-10) betzz = dphizz*dphizz/emzz
19116 if (emzz>1.e-10) gamzz = dez*dez/emzz
19118 if (betzz*gamzz>=1.) alpzz = sqrt(betzz*gamzz-1.)
19124 if (emx>1e-10) betx = dav2(i, 13)*dav2(i, 13)/emx
19126 if (emx>1e-10) gamx = dav2(i, 14)*dav2(i, 14)/emx
19128 if (betx*gamx>=1.) alpx = sqrt(betx*gamx-1.)
19135 if (emy>1e-10) bety = dav2(i, 18)*dav2(i, 18)/emy
19137 if (emy>1e-10) gamy = dav2(i, 19)*dav2(i, 19)/emy
19139 if (bety*gamy>=1.) alpy = sqrt(bety*gamy-1.)
19142 write (12, 3213) alpx, betx, alpy, bety, alpzz, betzz
19143 if (emzz>1000.)
then 19145 write (12, 6332) dav2(i, 10), dez, dav2(i, 23), emzz/1000., dav2(i, 30)
19148 write (12, 1002) dav2(i, 10), dez, dav2(i, 23), emzz, dav2(i, 30)
19151 write (12, 1003)(dav2(i,j), j=13, 22)
19154 if (iitem(i)==7)
then 19156 write (12, 7010) dav1(i, 4), dav1(i, 1), dav1(i, 36)
19157 7010
format (f9.2,
' mm Drift: length ', f10.3,
' mm ', /,
' particles left ', f7.0)
19160 if (iitem(i)==8)
then 19162 if (.not. imamin)
write (12, 8010) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 3), dav1(i, 36)
19163 8010
format (f9.2,
' mm Buncher ', f9.3,
' MV ',
' RF Phase ', f9.3,
' deg Aperture radius', f5.1,
' cm', /, &
19164 ' particles left ', f7.0)
19165 if (imamin)
write (12, 8110) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 5), dav1(i, 3), dav1(i, 36)
19166 8110
format (f9.2,
' mm Buncher ', f9.3,
' MV ',
' RF Phase ', f9.3,
' deg correction ', f9.3,
' deg', &
19167 ' Aperture radius', f5.1,
' cm', /,
' particles left ', f7.0)
19170 if (iitem(i)==9)
then 19172 if (dav1(i,2)==0.)
then 19173 write (12, 8020) dav1(i, 3), dav1(i, 1)
19174 8020
format (f9.2,
' mm Hor. Mag. Steerer ', e12.5,
' Tm ')
19175 else if (dav1(i,2)==1.)
then 19176 write (12, 8021) dav1(i, 3), dav1(i, 1)
19177 8021
format (f9.2,
' mm Ver. Mag. Steerer ', f12.5,
' Tm ')
19178 else if (dav1(i,2)==2.)
then 19179 write (12, 8022) dav1(i, 3), dav1(i, 1)
19180 8022
format (f9.2,
' mm Hor. El. Steerer ', e12.5,
' kVm/m ')
19181 else if (dav1(i,2)==3.)
then 19182 write (12, 8023) dav1(i, 3), dav1(i, 1)
19183 8023
format (f9.2,
' mm Ver. El. Steerer ', e12.5,
' kVm/m ')
19187 if (iitem(i)==10)
then 19189 write (12, 1011) dav1(i, 4), dav1(i, 1), dav1(i, 6), dav1(i, 3), dav1(i, 5), dav1(i, 2), dav1(i, 7), &
19191 1011
format (f9.2,
' mm Sextupole: length = ', f7.3,
' mm',
' aperture radius = ', e12.5,
' cm', /, &
19192 ' field = ', e12.5,
' kG KS2 = ', e12.5,
' cm-3',
' gradient = ', e12.5,
' kG/cm2', /, &
19193 ' momentum = ', e12.5,
' kG.cm particles left ', f7.0)
19196 if (iitem(i)==11)
then 19198 write (12, 5011) dav1(i, 4), dav1(i, 1), dav1(i, 7), dav1(i, 2), dav1(i, 6), dav1(i, 3), dav1(i, 5), &
19199 dav1(i, 8), dav1(i, 36)
19200 5011
format (f9.2,
' mm Sol+Quad: length = ', f7.3,
' mm aperture radius= ', e12.5,
' mm', /, &
19201 ' Solenoid: field = ', e12.5,
' kG K = ', e12.5,
' cm-1', /,
' Quadrupole: field ', e12.5,
' kG K2 = ', &
19202 e12.5,
' cm-2', /,
' momentum = ', e12.5,
' kG.cm particles left ', f7.0)
19205 if (iitem(i)==12)
then 19207 write (12, 5021) dav1(i, 4), dav1(i, 1), dav1(i, 6), dav1(i, 2), dav1(i, 3), dav1(i, 7), dav1(i, 8), &
19208 dav1(i, 10), dav1(i, 36)
19209 5021
format (f9.2,
' mm Quad+Sext: length = ', e12.5,
' mm ',
' aperture radius = ', e12.5,
' mm', /, &
19210 ' Quadrupole: B = ', e12.5,
' kG K2 = ', e12.5,
' cm-2', /,
' Sextupole: B = ', e12.5,
' kG K2 = ', &
19211 e12.5,
' cm-3', /,
' momentum = ', e12.5,
' kG.cm particles left ', f7.0)
19214 if (iitem(i)==13)
then 19216 write (12, 5031) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 3), dav1(i, 6), dav1(i, 36)
19217 5031
format (f9.2,
' mm DC egun length:', f7.3,
' mm', /,
' Crest field:', f8.3,
' MV/m', 3x,
' field stength:', &
19218 f8.3,
' kV', /,
' beta ( output):', e12.5,
' particles left ', f7.0)
19225 if (iitem(i)==14)
then 19226 ncell = int(dav1(i,7))
19227 write (12, 5041) dav1(i, 4), ncell, dav1(i, 1), dav1(i, 2), dav1(i, 3), dav1(i, 5), dav1(i, 6), dav1(i, 36)
19228 5041
format (f9.2,
' mm rfq cell:', i5,
' length: ', f7.3,
' mm', /,
' V/r02: ', e12.5,
' kV/mm**2 AV:', e12.5, &
19229 ' kV ',
' type: ', f3.0, /,
' energy(output): ', e12.5,
' MeV ',
' particles left ', f7.0)
19233 if (iitem(i)==15)
then 19234 ncell = int(dav1(i,7))
19235 write (12, 5042) dav1(i, 4), ncell, dav1(i, 5), dav1(i, 9), dav1(i, 8), dav1(i, 6), dav1(i, 36)
19236 5042
format (f9.2,
' mm rfq: number of cells:', i5,
' total length: ', e12.5,
' mm', /, &
19237 ' intervane voltage (reference): ', e12.5,
' kV', /,
' intervane voltage (bunch): ', e12.5,
' kV', /, &
19238 ' energy (output): ', e12.5,
' MeV', /,
' particles left ', f7.0)
19242 if (iitem(i)==16)
then 19243 write (12, 5043) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 3), dav1(i, 5), dav1(i, 6), dav1(i, 36)
19244 5043
format (f9.2,
' mm stripper: atomic number: ', f4.0,
' atomic mass : ', f4.0,
' thickness :', e12.5, &
19245 ' g/cm**2', /, 4x,
'particles charge : ', f4.0, 2x,
'energy loss: ', e12.5,
' MeV', /, &
19246 ' particles left ', f7.0)
19250 if (iitem(i)==17)
then 19251 n = int(dav1(i,25)+.5)
19261 write (12, 1008) dav1(i, 24), n, dav1(i, 1), dav1(i, 2), dav1(i, 38)
19263 1008
format (f9.2,
' mm Ac. gap ', i3,
' length ', f7.2,
' mm field ', e12.5,
' kV/mm phase of RF (middle): ', &
19268 if (iitem(i)==18)
then 19269 write (12, 2010) dav1(i, 4), dav1(i, 1), dav1(i, 7), dav1(i, 2), dav1(i, 6), dav1(i, 5), dav1(i, 3), &
19271 2010
format (f9.2,
' mm Quadrupole (electric): length = ', e12.5,
' mm aperture radius = ', e12.5,
' mm', /, &
19272 ' voltage = ', f8.3,
' kV K2 = ', e12.5,
' cm-2 gradient = ', e12.5,
' kV/(cm*cm) ', /,
' rigidity = ', &
19273 e12.5,
' kV particles left ', f7.0)
19277 if (iitem(i)==19)
then 19280 write (12, 2110) dav1(i, 4), dav1(i, 1), dav1(i, 7), dav1(i, 2), dav1(i, 6), dav1(i, 5), dav1(i, 3), &
19282 2110
format (f9.2,
' mm Quadrupole (electric): length = ', e12.5,
' mm aperture radius = ', e12.5,
' mm', /, &
19283 ' voltage = ', e12.5,
' kV K2 = ', e12.5,
' cm-2 gradient = ', e12.5,
' kV/cm2', /,
' rigidity = ', &
19284 e12.5,
' kV particles left ', f7.0)
19287 write (12, 2111) dav1(i, 4), dav1(i, 1), dav1(i, 7), dav1(i, 2), dav1(i, 6), dav1(i, 5), dav1(i, 3), &
19289 2111
format (f9.2,
' mm Quadrupole (magnetic): length = ', e12.5,
' mm aperture radius= ', e12.5,
' mm', /, &
19290 ' field = ', e12.5,
' kG K2 = ', e12.5,
' cm-2 gradient = ', e12.5,
' kG/cm', /,
' momentum = ', e12.5, &
19291 ' kG.cm particles left ', f7.0)
19295 if (iitem(i)==20)
then 19297 write (12, 2112) dav1(i, 1)
19298 2112
format (9x,
'rotating the transverse coordinates',
' about the z-axis by an angle: ', e12.5,
' deg')
19302 if (iitem(i)==21)
then 19303 write (12, 3010) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 3), dav1(i, 5), dav1(i, 6), dav1(i, 7), &
19304 dav1(i, 8), dav1(i, 36)
19305 3010
format (f9.2,
' mm Deflector (electric): length = ', e12.5,
' mm bend angle = ', e12.5,
' deg', /, &
19306 ' bend radius = ', e12.5,
' mm radii = ', e12.5,
' field index = ', e12.5, /,
' rigidity = ', e12.5, &
19307 ' kV field = ', e12.5,
' kV/mm',
' particles left ', f7.0)
19313 end subroutine daves 19322 implicit real *8(a-z)
19324 common /bloc21/be, apb(2), layl, layx, rabt
19325 common /bloc23/h, devi, nb, bdb, l
19326 common /bloc11/r(6, 6), t(6, 6, 6)
19327 common /secdr/iseor
19348 sb = (1.0+sin(be)**2)/cb
19349 tcor = 2.0*h*
gap*layl
19350 be1 = be - tcor*sb*(1.-layx*tcor*tb)
19355 if (.not. iseor)
go to 3333
19359 t(1, 1, 1) = -0.5*h*tb2
19360 t(1, 3, 3) = 0.5*h*
sb2 19361 t(2, 1, 1) = 0.5*h*rabt*
sb3 - tb*nb*h**2
19364 t(2, 3, 3) = h**2*(nb+0.5+tb2)*tb - 0.5*h*rabt*
sb3 19365 t(2, 3, 4) = -h*tb2
19367 t(4, 1, 3) = -h*rabt*
sb3 + 2.*h**2*nb*tb
19368 t(4, 1, 4) = -h*tb2
19369 t(4, 2, 3) = -h*
sb2 19370 sec2 = cos(be1)*cos(be1)
19372 t(4, 3, 6) = h*tb - h*tcor*sec2
19388 implicit real *8(a-z)
19390 common /bloc21/be, apb(2), layl, layx, rabt
19391 common /bloc23/h, devi, nb, bdb, l
19392 common /bloc11/r(6, 6), t(6, 6, 6)
19393 common /secdr/iseor
19413 sb = (1.0+sin(be)**2)/cb
19414 tcor = 2.0*h*
gap*layl
19415 be1 = be - tcor*sb*(1.-layx*tcor*tb)
19420 if (.not. iseor)
go to 4444
19424 t(1, 1, 1) = 0.5*h*tb2
19425 t(1, 3, 3) = -0.5*h*
sb2 19426 t(2, 1, 1) = 0.5*h*rabt*
sb3 - tb*(nb+0.5*tb2)*h**2
19427 t(2, 1, 2) = -h*tb2
19429 t(2, 3, 3) = h**2*(nb-0.5*tb2)*tb - 0.5*h*rabt*
sb3 19431 t(3, 1, 3) = -h*tb2
19432 t(4, 1, 3) = -h*rabt*
sb3 + h**2*(2.*nb+
sb2)*tb
19435 sec2 = cos(be1)*cos(be1)
19437 t(4, 3, 6) = h*tb - h*tcor*sec2
19451 subroutine benmag(sbet, fdtot)
19452 implicit real *8(a-z)
19454 common /bloc21/be, apb(2), layl, layx, rabt
19455 common /bloc23/h, devi, nb, bdb, l
19456 common /bloc11/r(6, 6), t(6, 6, 6)
19457 common /secdr/iseor
19470 sgam2 = 1./(1.-sbet*sbet)
19483 kx2 = (1.0-fieldn)*h2
19485 kx = sqrt(abs(kx2))
19486 ky = sqrt(abs(ky2))
19501 dx = h*(1.0-cx)/kx2
19502 j1xl = (argx-shx)/kx3
19504 if (kx2==6.*0)
then 19513 dx = h*(1.0-cx)/kx2
19514 j1xl = (argx-sinx)/kx3
19525 if (ky2==6.*0)
then 19550 r(5, 6) = r(5, 6) - al*fdtot/sgam2
19552 if (.not. iseor)
go to 3334
19565 targx = argx + argx
19573 targy = argy + argy
19582 c = 1.0/(kx2-4.0*ky2)
19602 sx = dsin(kx*al)/kx
19603 dx = h*(1.0d0-cx)/kx2
19604 j1xl = (argx-sinx)/kx3
19605 j2xl = (1.0-cosx-.5*argx*sinx)/kx4
19606 j3xl = .5*(sinx-argx*cosx)/kx3
19607 j4xl = (.5*argx-2.0*sinx/3.0+sin2x/12.)/kx5
19608 j5xl = (.25d0-cosx/3.0+cos2x/12.0)/kx4
19609 j10xl = (argx-1.5*sinx+.5*argx*cosx)/kx5
19610 j11xl = (-2.0*argx+3.0*sinx-argx*cosx)/kx5
19611 j12xl = (4.0*argx-5.5*sinx+1.5*argx*cosx)/kx3
19612 j13xl = (.75-2.0*cosx/3.0-cos2x/12.0-.5*argx*sinx)/kx6
19613 j14xl = (1.5-4.0*cosx/3.0-cos2x/6.0-argx*sinx)/kx6
19614 j15xl = (-1.75+4.0*cosx/3.0+5.0*cos2x/12.0+1.5*argx*sinx)/kx4
19615 j16xl = (1.5*argx-7.0*sinx/3.0-sin2x/12.0+argx*cosx)/kx7
19616 j17xl = (-1.75*argx+17.0*sinx/6.0+5.0*sin2x/24.0-1.5*argx*cosx)/kx5
19617 j1l = (.5*argx-.25*sin2x)/kx3
19618 j2l = (.5*argx+.25*sin2x)/kx
19619 j3l = .25*(1.0-cos2x)/kx2
19621 j7xl = .5*(argx-sinx+kx2*c*(sinx-.5*kx*sh2y/ky))/(kx3*ky2)
19622 j9xl = c*((cosx-1.0)/kx2+(1.0-ch2y)/(4.0*ky2))
19624 if (ky2==6.*0)
then 19625 j7xl = (2.0*(sinx-argx)/kx3+al3/3.0)/kx2
19626 j9xl = al2/(2.0*kx2) + (cosx-1.0)/kx4
19629 j7xl = .5*(argx-sinx+kx2*c*(sinx-.5*kx*sin2y/ky))/(kx3*ky2)
19630 j9xl = c*((cosx-1.0)/kx2+(1.0-cos2y)/(4.0*ky2))
19636 sx = sinh(kx*al)/kx
19637 dx = h*(1.0-cx)/kx2
19638 j1xl = (argx-shx)/kx3
19639 j2xl = (1.0-chx+.5*argx*shx)/kx4
19640 j3xl = .5*(shx-argx*chx)/kx3
19641 j4xl = (.5*argx-2.0*shx/3.0+sh2x/12.0)/kx5
19642 j5xl = (.25-chx/3.0+ch2x/12.0)/kx4
19643 j10xl = (argx-1.5*shx+.5*argx*chx)/kx5
19644 j11xl = (-2.0*argx+3.0*shx-argx*chx)/kx5
19645 j12xl = (4.0*argx-5.5*shx+1.5*argx*chx)/kx3
19646 j13xl = (.75-2.0*chx/3.0-ch2x/12.0+.5*argx*shx)/kx6
19647 j14xl = (1.5-4.0*chx/3.0-ch2x/6.0+argx*shx)/kx6
19648 j15xl = (-1.75+4.0*chx/3.0+5.0*ch2x/12.0-1.5*argx*shx)/kx4
19649 j16xl = (1.5*argx-7.0*shx/3.0-sh2x/12.0+argx*chx)/kx7
19650 j17xl = (-1.75*argx+17.0*shx/6.0+5.0*sh2x/24.0-1.5*argx*chx)/kx5
19651 j1l = (.5*argx-.25*sh2x)/kx3
19652 j2l = (.5*argx+.25*sh2x)/kx
19653 j3l = .25*(1.0-ch2x)/kx2
19655 j7xl = .5*(argx-shx+kx2*c*(shx-.5*kx*sh2y/ky))/(kx3*ky2)
19656 j9xl = c*((chx-1)/kx2+(1.0d0-ch2y)/(4.0d0*ky2))
19658 if (ky2==6.*0)
then 19659 j7xl = (2.0*(sinx-argx)/kx3+al3/3.0d0)/kx2
19660 j9xl = al2/(2.0d0*kx2) + (chx-1.0d0)/kx4
19663 j7xl = .5*(argx-shx+kx2*c*(shx-.5d0*kx*sin2y/ky))/(kx3*ky2)
19664 j9xl = c*((chx-1.0)/kx2+(1.0-cos2y)/(4.0*ky2))
19668 if (kx2==6.*0)
then 19677 j7xl = (al3/12.0-al/(8.0*ky2)-sin2y/(16.0*ky3))/ky2
19681 j9xl = al2/(8.0*ky2) - (1.0-cos2y)/(16.0*ky4)
19700 sy = sinh(ky*al)/ky
19701 j4l = (.5*argy-.25*sh2y)/ky3
19702 j5l = (.5*argy+.25*sh2y)/ky
19703 j6l = .25*(1.0-ch2y)/ky2
19705 if (ky2==6.*0)
then 19715 j4l = (.5*argy-.25*sin2y)/ky3
19716 j5l = (.5*argy+.25*sin2y)/ky
19717 j6l = .25*(1.0-cos2y)/ky2
19722 a = 2.0*fieldn - 1.0 - beta
19724 bn1 = 2.0*fieldn - 1.0 - beta
19725 bn2 = 2.5*fieldn - beta - 1.5
19726 bn3 = 2.0*beta - fieldn
19730 i111 = 1.0*(sx**2+dx*rad)/3.0
19731 i112 = sx*dx*rad/3.0
19732 i133 = dx/h - (ky2/(kx2-4.0*ky2))*(sy2-2.0*dx*rad)
19733 i134 = c*(sy*cy-sx)
19734 i144 = (sy2-2.0*dx*rad)*c
19736 i21 = (sx+al*cx)/2.0
19738 i211 = sx*(1.0+2.0*cx)/3.0
19739 i212 = (2.0*sx**2-dx/h)/3.0
19740 i222 = 2.0*sx*dx*rad/3.0
19741 i233 = sx - 2.0*ky2*(sy*cy-sx)*c
19742 i234 = (kx2*dx*rad-2.0*ky2*sy2)*c
19743 i244 = 2.0*c*(sy*cy-sx)
19745 if (ky2==6.*0) i34 = al3/6.0
19746 if (ky2/=6.*0) i34 = 0.5*(sy-al*cy)/ky2
19747 i314 = (2.0*sx*cy-sy*(1.0+cx))*c
19748 i324 = c*(2.0*cy*dx*rad-sx*sy)
19749 i43 = 0.5*(sy+al*cy)
19751 i413 = c*((kx2-2.0*ky2)*sx*cy-ky2*sy*(1.0+cx))
19752 i414 = c*((kx2-2.0*ky2)*sx*sy-cy*(1.0-cx))
19753 i424 = c*(cy*sx-cx*sy-2.0*ky2*sy*dx*rad)
19754 i12 = (sx-al*cx)*0.5/kx2
19755 i27 = (dx*rad-.5*al*sx)/kx2
19756 i313 = c*(kx2*cy*dx*rad-2.0*sx*sy*ky2)
19757 i314 = (2.0*sx*cy-sy*(1.0+cx))*c
19758 i324 = c*(2.0*cy*dx*rad-sx*sy)
19759 i43 = 0.5*(sy+al*cy)
19761 i413 = c*((kx2-2.0*ky2)*sx*cy-ky2*sy*(1.0+cx))
19762 i414 = c*((kx2-2.0*ky2)*sx*sy-cy*(1.0-cx))
19763 i424 = c*(cy*sx-cx*sy-2.0*ky2*sy*dx*rad)
19765 i12 = (sx-al*cx)*0.5/kx2
19766 i27 = (dx*rad-.5*al*sx)/kx2
19767 i116 = (0.5*al*sx-(sx**2+dx/h)/3.0)*h/kx2
19768 i122 = (2.0*dx/h-sx**2)/3.0/kx2
19769 i126 = h*(sx+2.0*sx*cx-3.0*al*cx)/6.0/kx2**2
19770 i166 = h2*(4.0*dx*rad/3.0+sx**2/3.0-al*sx)/kx2**2
19771 i216 = h*(al*cx/2.0+sx/6.0-2.0*sx*cx/3.0)/kx2
19772 i226 = h*(0.5*al*sx-2.0*sx**2/3.0+dx*rad/3.0)/kx2
19773 i266 = h2*(sx/3.0+2.0*sx*cx/3.0-al*cx)/kx2**2
19774 i323 = c*(2.0*ky2*sy*(1.0+cx)/kx2-sx*cy) + sy/kx2
19775 i336 = h*(0.5*al*sy-c*(cy*(1.0-cx)-2.0*ky2*sx*sy))/kx2
19776 i346 = h*(i34-c*(2.0*sx*cy-sy*(1.0+cx)))/kx2
19777 i423 = c*(2.0*ky2*cy*(1.0+cx)/kx2-cx*cy-ky2*sx*sy) + cy/kx2
19778 i436 = h*(0.5*al*cy+0.5*sy+c*(ky2*sy*(1.0+cx)-(kx2-2.0*ky2)*sx*cy))/kx2
19779 i446 = h*(al*sy*0.5-c*((kx2-2.0*ky2)*sx*sy-cy*(1.0-cx)))/kx2
19787 i166 = h2*al2/120.0
19792 i336 = h*al*(al2*sy/12.0+(al*cy-sy)/(ky2*8.0))
19793 i346 = h*al2*(sy/(ky2*8.0)-al*cy/(ky2*12.0))
19794 i423 = (al2*cy+al*sy)/4.0
19795 i436 = h*al2*(sy/8.0+cy*al/12.0)
19796 i446 = h*al*(al2*sy/12.0+(sy-al*cy)/(ky2*8.0))
19801 t(1, 1, 1) = a*h3*i111 + 0.5*kx2**2*i122*h
19802 t(1, 1, 2) = 2.0*a*h3*i112 - kx2*h*i112 + h*sx
19803 t(1, 1, 6) = b*h2*i11 + 2.0*a*h3*i116 - kx2*h2*i122
19804 t(1, 2, 2) = a*h3*i122 + 0.5*h*i111
19805 t(1, 2, 6) = b*h2*i12 + 2.0*a*h3*i126 + h2*i112
19806 t(1, 3, 3) = beta*h3*i133 - 0.5*ky2*h*i10
19807 t(1, 3, 4) = 2.0*beta*h3*i134
19808 t(1, 4, 4) = beta*h3*i144 - 0.5*h*i10
19809 t(1, 6, 6) = b*h2*h*i27 + a*h3*i166 + 0.5d0*h3*i122 - h*i10
19811 t(2, 1, 1) = a*h3*i211 + 0.5*kx2**2*h*i222 - h*cx*cpx
19812 t(2, 1, 2) = h*spx + 2.0d0*a*h3*i212 - kx2*h*i212 - h*(cx*spx+cpx*sx)
19813 t(2, 1, 6) = b*h2*i21 + 2.0*a*h3*i216 - kx2*h2*i222 - h*(cx*dpx+cpx*dx)
19814 t(2, 2, 2) = a*h3*i222 + 0.5*h*i211 - h*sx*spx
19815 t(2, 2, 6) = b*h2*i22 + 2.0*a*h3*i226 + h2*i212 - h*(sx*dpx+spx*dx)
19816 t(2, 3, 3) = beta*h3*i233 - 0.5*ky2*h*i20
19817 t(2, 3, 4) = 2.0*beta*h3*i234
19818 t(2, 4, 4) = beta*h3*i244 - 0.5*h*i20
19819 t(2, 6, 6) = b*h2*i26 + a*h3*i266 + 0.5*h3*i222 - h*dx*dpx - h*i20
19825 t(3, 1, 3) = 2.0*b*h3*i313 + kx2*ky2*h*i324
19826 t(3, 1, 4) = h*sy + 2.0d0*b*h3*i314 - kx2*h*i323
19827 t(3, 2, 3) = 2.0*b*h3*i323 - ky2*h*i314
19828 t(3, 2, 4) = 2.0*b*h3*i324 + h*i313
19829 t(3, 3, 6) = ky2*i33 + 2.0*b*h3*i336 - ky2*h2*i324
19830 t(3, 4, 6) = ky2*i34 + 2.0*b*h3*i346 + h2*i323
19832 t(4, 1, 3) = 2.0*b*h3*i413 + kx2*ky2*h*i424 - h*cx*cpy
19833 t(4, 1, 4) = h*spy + 2.0*h3*b*i414 - kx2*h*i423 - h*cx*spy
19834 t(4, 2, 3) = 2.0*b*h3*i423 - ky2*h*i414 - h*sx*cpy
19835 t(4, 2, 4) = 2.0*b*h3*i424 + h*i413 - h*sx*spy
19836 t(4, 3, 6) = ky2*i43 + 2.0*b*h3*i436 - ky2*h2*i424 - h*dx*cpy
19837 t(4, 4, 6) = ky2*i44 + 2.0*b*h3*i446 + h2*i423 - h*dx*spy
19839 t(5, 1, 1) = h4*(bn1*j1xl-bn2*kx2*j4xl) + .5*kx4*j1l
19840 t(5, 1, 2) = h4*2.0*bn2*j5xl - kx2*j3l + h*dx
19841 t(5, 1, 6) = h5*j11xl + h3*j12xl + h*kx2*j3xl + h5*2.0*bn2*j4xl + 2.0*beta*h5*j10xl - h*kx2*j1l
19843 t(5, 1, 6) = t(5, 1, 6) - r(5, 1)/sgam2
19845 t(5, 2, 2) = .5*(h2*j1xl+h4*2.0*bn2*j4xl+j2l)
19846 t(5, 2, 6) = -2.0*beta*h5*j13xl + h5*j14xl + h3*j15xl + h*kx2*j2xl + h*j3l
19848 t(5, 2, 6) = t(5, 2, 6) - r(5, 2)/sgam2
19850 t(5, 3, 3) = .5*(h4*(bn3*j1xl-2.0*beta*ky2*j7xl)+ky4*j4l)
19851 t(5, 3, 4) = 2.0*beta*h4*j9xl - ky2*j6l
19852 t(5, 4, 4) = beta*h4*j7xl - .5*(h2*j1xl-j5l)
19853 t(5, 6, 6) = (1.0-beta)*h6*j16xl + h4*j17xl - h2*j3xl + .5*h2*j1l
19855 t(5, 6, 6) = t(5, 6, 6) - r(5, 6)/sgam2
19856 t(5, 6, 6) = t(5, 6, 6) + al*((1./sgam2)**2+1.5*sbet*sbet/sgam2)
19858 t(5, 5, 6) = -1./sgam2
19870 implicit real *8(a-h, o-z)
19871 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
19872 common /consta/vl, pi, xmat, rpel, qst
19873 common /faisc/f(10, iptsz), imax, ngood
19874 common /bloc11/r(6, 6), t(6, 6, 6)
19875 common /radia/trt, rmoy, xintf, crae
19891 gpaii = f(7, ii)/xmat
19892 cgam = (4.*pi/3.)*crae/(xmat**3)
19893 pgam = vl*cgam*e4ii/(2.*pi*rmoy*rmoy)
19895 elost = xintf*pgam*trt
19897 dmo = -elost/f(7, ii)
19899 f(7, ii) = f(7, ii) - elost
19902 f(2, ii) = f(2, ii) + dmo*r(1, 6)*100.
19903 f(3, ii) = f(3, ii) + dmo*r(2, 6)*1000.
19912 implicit real *8(a-h, o-z)
19913 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
19914 common /consta/vl, pi, xmat, rpel, qst
19915 common /radia/trt, rmoy, xintf, crae
19916 common /dyn/tref, vref
19917 common /bloc23/h, devi, nb, bdb, l
19918 common /itvole/itvol, imamin
19919 common /tofev/ttvols
19920 logical itvol, imamin
19924 gamref = 1./sqrt(1.-beref*beref)
19925 ener = xmat*gamref*beref
19928 cgam = (4.*pi/3.)*crae/(xmat**3)
19929 pgam = vl*cgam*e4/(2.*pi*rmoy*rmoy)
19932 elost = xintf*pgam*trt
19933 fener = ener - elost
19935 fberef = sqrt(1.-1./(fgam*fgam))
19937 tref = tref + l/vref
19938 if (itvol) ttvols = tref
19939 write (16, 250) elost, ener, fener
19940 250
format (//,
' REFERENCE AFTER RADIATION EXITATION*****', /,
' ENERGY LOST (MeV): ', e12.5, /, &
19941 ' OLD ENERGY (MeV): ', e12.5, /,
' NEW ENERGY (MeV): ', e12.5)
19943 end subroutine syref 19949 subroutine sextu(imk2, arg, xlsex, rg)
19950 implicit real *8(a-h, o-z)
19951 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
19952 common /fene/wdisp, wphas, wx, wy, rlim, ifw
19953 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
19954 common /dyn/tref, vref
19955 common /consta/vl, pi, xmat, rpel, qst
19957 common /faisc/f(10, iptsz), imax, ngood
19958 common /etcom/cog(8), exten(17), fd(iptsz)
19959 common /qmoyen/qmoy
19962 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
19964 common /tapes/in, ifile, meta
19965 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
19966 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
19967 common /shif/dtiph, shift
19969 common /compt/nrres, nrtre, nrbunc, nrdbun
19970 common /rander/ialin
19972 common /qskew/qtwist, iqrand, itwist, iaqu
19974 common /femt/iemgrw, iemqesg
19976 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
19977 common /qsex/l, kq2, ks2
19978 real *8 l, kq2, ks2
19983 write (16, *)
' ******SEXTUPOLE*********' 19985 if (iprf==1)
call stapl(davtot*10.)
19989 write (6, 8254) nrtre, nrres, cr
19990 8254
format (
'Transport element:', i5,
' Accelerating element:', i5, a1, $)
19994 if (itwist .and. arg/=0.)
then 19995 if (iqrand==0)
then 20001 call rlux(trans, len)
20002 if (trans(1)<=rdcf) sign = -1.
20003 if (trans(1)>rdcf) sign = 1.
20004 call rlux(trans, len)
20005 qtwrad = qtwist*sign*trans(1)
20012 write (16, *)
'TOF at input:', tref*fh*180./pi,
' deg' 20016 gpa = gpa + f(7, ii)/xmat
20018 gpa = gpa/float(ngood)
20020 bpa = sqrt(1.-1./(gpa*gpa))
20021 xmco = xmat*bpa*gpa
20022 ri = 33.356*xmco*1.e-01/qst
20034 write (16, 3300) xlsex, rg, fb, ks2, b, ri
20035 3300
format (
' LENGTH = ', e12.3,
' cm APERTURE RADIUS= ', e12.5,
' cm', /,
' FIELD = ', e12.5,
' kG KS2 = ', e12.5, &
20036 ' cm-3',
' GRADIENT = ', e12.5,
' kG/(cm*cm)', /,
' MOMENTUM = ', e12.5,
' kG.cm', /)
20044 dav1(idav, 1) = xlsex*10.
20047 davtot = davtot + xlsex
20048 dav1(idav, 4) = davtot*10.
20049 dav1(idav, 5) = ks2
20056 gpai = f(7, ii)/xmat
20057 bpai = sqrt(1.-1./(gpai*gpai))
20058 xmco = xmat*bpai*gpai
20059 ri = 33.356*xmco*1.e-01/f(9, ii)
20067 if (ichaes .and. l>0.)
then 20068 if (sce10==1 .or. sce10==3.)
then 20070 write (16, *)
'space charge at the middle ' 20077 gpai = f(7, i)/xmat
20078 bcour = sqrt(1.-1./(gpai*gpai)) + bcour
20080 bcour = bcour/float(ngood)
20081 gcour = 1./sqrt(1.-bcour*bcour)
20082 wcg = (gcour-1.)*xmat
20086 if (ifw==0) dispr = gcour*gcour*wdisp/(gcour*(gcour+1.))
20087 if (ifw==1) dispr = gcour*gcour*wdisp/(gcour*(gcour+1.)*wcg)
20090 gpai = f(7, i)/xmat
20091 bpai = sqrt(1.-1./(gpai*gpai))
20092 fd(i) = bpai/bcour*gpai/gcour
20097 tref = tref + xlsex/(2.*vref)
20105 gpai = f(7, ii)/xmat
20106 bpai = sqrt(1.-1./(gpai*gpai))
20107 xmco = xmat*bpai*gpai
20108 ri = 33.356*xmco*1.e-01/f(9, ii)
20116 tref = tref + xlsex/(2.*vref)
20118 ilost = ilost + nlost
20121 dav1(idav, 36) = ngood
20122 write (16, *)
'TOF at output:', tref*fh*180./pi,
' deg' 20123 write (16, *)
' particles lost in sextupole :', ilost
20125 if (itwist .and. b/=0.)
then 20129 if (iemgrw)
call emiprt(0)
20130 call stapl(davtot*10.)
20132 end subroutine sextu 20142 subroutine qalva(bquad, xlqua, rg)
20143 implicit real *8(a-h, o-z)
20144 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
20145 common /fene/wdisp, wphas, wx, wy, rlim, ifw
20146 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
20147 common /dyn/tref, vref
20148 common /consta/vl, pi, xmat, rpel, qst
20150 common /faisc/f(10, iptsz), imax, ngood
20151 common /etcom/cog(8), exten(17), fd(iptsz)
20152 common /qmoyen/qmoy
20155 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
20157 common /tapes/in, ifile, meta
20158 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
20159 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
20160 common /shif/dtiph, shift
20162 common /compt/nrres, nrtre, nrbunc, nrdbun
20163 common /rander/ialin
20165 common /qskew/qtwist, iqrand, itwist, iaqu
20167 common /femt/iemgrw, iemqesg
20169 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
20170 common /qsex/l, kq2, ks2
20171 common /tofev/ttvols
20172 common /itvole/itvol, imamin
20173 logical itvol, imamin
20174 real *8 l, kq2, ks2
20180 write (6, 8254) nrtre, nrres, cr
20181 8254
format (
'Transport element:', i5,
' Accelerating element:', i5, a1, $)
20186 if (iprf==1)
call stapl(davtot*10.)
20187 write (16, *)
' ***QUADRUPOLE (magnetic) ***' 20189 if (itvol)
write (16, 10) ttvols*fcpi, davtot
20190 10
format (
' ** TOF (input of the lens): ', e12.5,
' deg at: ', e12.5,
' cm in the lattice')
20194 if (itwist .and. b/=0.)
then 20195 if (iqrand==0)
then 20201 call rlux(trans, len)
20202 if (trans(1)<=rdcf) sign = -1.
20203 if (trans(1)>rdcf) sign = 1.
20204 call rlux(trans, len)
20205 qtwrad = qtwist*sign*trans(1)
20217 gpa = gpa + f(7, ii)/xmat
20219 gpa = gpa/float(ngood)
20221 bpa = sqrt(1.-1./(gpa*gpa))
20222 xmco = xmat*bpa*gpa
20223 ri = 33.356*xmco*1.e-01/qst
20227 write (16, 3300) xlqua, rg, bquad, kq2, b, ri
20228 3300
format (
' LENGTH = ', e12.5,
' cm APERTURE RADIUS= ', e12.5,
' cm', /,
' FIELD = ', e12.5,
' kG K2 = ', e12.5, &
20229 ' cm-2 ',
' GRADIENT = ', e12.5,
' kG/cm', /,
' MOMENTUM = ', e12.5,
' kG.cm', /)
20234 dav1(idav, 1) = xlqua*10.
20235 dav1(idav, 2) = bquad
20236 davtot = davtot + xlqua
20237 dav1(idav, 4) = davtot*10.
20238 dav1(idav, 3) = kq2
20241 dav1(idav, 7) = rg*10.
20246 gpai = f(7, ii)/xmat
20247 bpai = sqrt(1.-1./(gpai*gpai))
20248 xmco = xmat*bpai*gpai
20249 ri = 33.356*xmco*1.e-01/f(9, ii)
20255 if (ichaes .and. l>0.)
then 20256 if (sce10==1 .or. sce10==3.)
then 20258 write (16, *)
'space charge at the middle ' 20269 gpai = f(7, i)/xmat
20270 bcour = sqrt(1.-1./(gpai*gpai)) + bcour
20272 bcour = bcour/float(ngood)
20273 gcour = 1./sqrt(1.-bcour*bcour)
20274 wcg = (gcour-1.)*xmat
20277 tref = tref + xlqua/(2.*vref)
20284 gpai = f(7, ii)/xmat
20285 bpai = sqrt(1.-1./(gpai*gpai))
20286 xmco = xmat*bpai*gpai
20287 ri = 33.356*xmco*1.e-01/f(9, ii)
20303 tref = tref + xlqua/(2.*vref)
20305 ilost = ilost + nlost
20308 if (itvol) ttvols = tref
20311 tcog = tcog + f(6, i)
20313 tcog = tcog/float(ngood)
20315 write (16, 11) ttvols*fcpi, davtot, tref*fcpi, tcog*fcpi
20316 11
format (
' ** tof: ', e12.5,
' deg at: ', e12.5,
' cm in the lattice', /, 3x,
'tof of the reference: ', e12.5, &
20317 ' deg tof of the cog: ', e12.5,
' deg')
20319 write (16, 12) tref*fcpi, tcog*fcpi
20320 12
format (
' ** tof of the reference: ', e12.5,
' deg tof of the cog: ', e12.5,
' deg')
20322 dav1(idav, 36) = ngood
20323 write (16, *)
' particles lost in quadrupole :', ilost
20325 if (itwist .and. b/=0.)
then 20329 if (iemgrw)
call emiprt(0)
20331 call stapl(davtot*10.)
20333 end subroutine qalva 20346 subroutine qasex(iksq, args, argq, xlqua, rg)
20347 implicit real *8(a-h, o-z)
20348 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
20349 common /fene/wdisp, wphas, wx, wy, rlim, ifw
20350 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
20351 common /dyn/tref, vref
20352 common /consta/vl, pi, xmat, rpel, qst
20354 common /faisc/f(10, iptsz), imax, ngood
20355 common /etcom/cog(8), exten(17), fd(iptsz)
20356 common /qmoyen/qmoy
20359 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
20361 common /tapes/in, ifile, meta
20362 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
20363 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
20364 common /shif/dtiph, shift
20366 common /compt/nrres, nrtre, nrbunc, nrdbun
20367 common /rander/ialin
20369 common /qskew/qtwist, iqrand, itwist, iaqu
20371 common /femt/iemgrw, iemqesg
20373 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
20374 common /qsex/l, kq2, ks2
20375 real *8 l, kq2, ks2
20380 write (6, 8254) nrtre, nrres, cr
20381 8254
format (
'Transport element:', i5,
' Accelerating element:', i5, a1, $)
20385 if (iprf==1)
call stapl(davtot*10.)
20408 gpa = gpa + f(7, ii)/xmat
20410 gpa = gpa/float(ngood)
20412 bpa = sqrt(1.-1./(gpa*gpa))
20413 xmco = xmat*bpa*gpa
20414 ri = 33.356*xmco*1.e-01/qst
20438 write (16, *)
' *****LENS QUADRUPOLE+SEXTUPOLE ********' 20439 write (16, 3300) xlqua, rg, fq, kq2, bq, fs, ks2, bs, ri
20440 3300
format (
' LENS: LENGTH = ', e12.5,
' cm APERTURE RADIUS = ', e12.5,
' cm', /,
' QUADRUPOLE: FIELD = ', e12.5, &
20441 ' kG KQ2 = ', e12.5,
' cm-2 GRADIENT = ', e12.5,
' kG/cm', /,
' SEXTUPOLE: FIELD = ', e12.5,
' kG KS2 = ', &
20442 e12.5,
' cm-3',
' GRADIENT = ', e12.5,
' kG/(cm*cm)', /,
' MOMENTUM = ', e12.5,
' kG.cm', /)
20444 write (16, *)
'TOF at input:', tref*fh*180./pi,
' deg' 20450 dav1(idav, 1) = xlqua*10.
20451 dav1(idav, 6) = rg*10.
20453 dav1(idav, 3) = kq2
20456 dav1(idav, 8) = ks2
20458 dav1(idav, 10) = ri
20459 davtot = davtot + xlqua
20460 dav1(idav, 4) = davtot*10.
20465 gpai = f(7, ii)/xmat
20466 bpai = sqrt(1.-1./(gpai*gpai))
20467 xmco = xmat*bpai*gpai
20468 ri = 33.356*xmco*1.e-01/f(9, ii)
20486 if (ichaes .and. l>0.)
then 20487 if (sce10==1 .or. sce10==3.)
then 20489 write (16, *)
'space charge at the middle ' 20499 gpai = f(7, i)/xmat
20500 bcour = sqrt(1.-1./(gpai*gpai)) + bcour
20502 bcour = bcour/float(ngood)
20503 gcour = 1./sqrt(1.-bcour*bcour)
20504 wcg = (gcour-1.)*xmat
20508 tref = tref + xlqua/(2.*vref)
20515 gpai = f(7, ii)/xmat
20516 bpai = sqrt(1.-1./(gpai*gpai))
20517 xmco = xmat*bpai*gpai
20518 ri = 33.356*xmco*1.e-01/f(9, ii)
20538 tref = tref + xlqua/(2.*vref)
20540 ilost = ilost + nlost
20543 dav1(idav, 36) = ngood
20544 write (16, *)
'TOF at output:', tref*fh*180./pi,
' deg' 20545 write (16, *)
' particles lost:', ilost
20551 if (iemgrw)
call emiprt(0)
20552 call stapl(davtot*10.)
20554 end subroutine qasex 20563 implicit real *8(a-z)
20564 common /qsex/l, kq2, ks2
20565 common /bloc11/r(6, 6), t(6, 6, 6)
20566 common /secdr/iseor
20571 akq = sqrt(abs(akq2))
20572 if (akq<1.e-13) akq = 1.e-13
20591 r(2, 1) = -akq2*ssok
20595 r(4, 3) = akq2*bsok
20597 if (.not. iseor)
return 20599 t(1, 1, 6) = al*akq2*ssok/2.0
20601 t(1, 2, 6) = (ssok-al*sc)/2.0
20603 t(2, 1, 6) = akq2*(ssok+al*sc)/2.0
20605 t(2, 2, 6) = t(1, 1, 6)
20607 t(3, 3, 6) = -al*akq2*bsok/2.0
20608 t(3, 4, 6) = (bsok-al*bc)/2.0
20610 t(4, 3, 6) = -akq2*(bsok+al*bc)/2.0
20611 t(4, 4, 6) = t(3, 3, 6)
20613 t(5, 1, 1) = akq2*(al-sc*ssok)/4.0
20614 t(5, 1, 2) = -akq2*ssok*ssok/2.0
20615 t(5, 2, 2) = (al+sc*ssok)/4.0
20616 t(5, 3, 3) = -akq2*(al-bc*bsok)/4.0
20618 t(5, 3, 4) = akq2*(bsok*bsok)/2.0
20619 t(5, 4, 4) = (al+bc*bsok)/4.0
20621 end subroutine elqua 20630 implicit real *8(a-z)
20631 common /qsex/l, kq2, ks2
20632 common /bloc11/r(6, 6), t(6, 6, 6)
20633 common /secdr/iseor
20651 if (.not. iseor)
return 20653 t(5, 2, 2) = al/2.0
20654 t(5, 4, 4) = al/2.0
20655 if (aks2==0.0)
return 20657 t(1, 1, 1) = -akl2/2.0
20658 t(1, 1, 2) = -akl3/3.0
20659 t(1, 2, 2) = -akl4/12.0
20661 t(1, 3, 3) = akl2/2.0
20662 t(1, 3, 4) = akl3/3.0
20663 t(1, 4, 4) = akl4/12.0
20667 t(2, 2, 2) = -akl3/3.0
20671 t(2, 4, 4) = akl3/3.0
20674 t(3, 1, 4) = akl3/3.0
20675 t(3, 2, 3) = akl3/3.0
20676 t(3, 2, 4) = akl4/6.0
20678 t(4, 1, 3) = akl1*2.0
20681 t(4, 2, 4) = akl3*2.0/3.0
20683 end subroutine elsex 20693 implicit real *8(a-z)
20694 common /qsex/l, kq2, ks2
20695 common /bloc11/r(6, 6), t(6, 6, 6)
20696 common /secdr/iseor
20704 akq = sqrt(abs(akq2))
20710 if (akq2>6.*0)
then 20721 if (akq2==6.*0)
then 20727 r(2, 1) = -akq2*ssok
20731 r(4, 3) = akq2*bsok
20734 if (.not. iseor)
return 20736 if (akq2==6.*0)
then 20741 t(1, 1, 1) = -aks2*(ssok*ssok+(1.0-sc)/akq2)/3.0
20742 t(1, 1, 2) = -2.0*aks2*(ssok*(1.0-sc)/akq2)/3.0
20743 t(1, 1, 6) = al*akq2*ssok/2.0
20745 t(1, 2, 2) = -aks2*(2.0*(1.0-sc)/akq2-ssok*ssok)/(3.0*akq2)
20746 t(1, 2, 6) = (ssok-al*sc)/2.0
20748 t(1, 3, 3) = aks2*(bsok*bsok+3.0*(1.0-sc)/akq2)/5.0
20749 t(1, 3, 4) = 2.0*aks2*(bsok*bc-ssok)/(5.0*akq2)
20750 t(1, 4, 4) = aks2*(bsok*bsok-2.0*(1.0-sc)/akq2)/(5.0*akq2)
20752 t(2, 1, 1) = -aks2*(2.0*ssok*sc+ssok)/3.0
20753 t(2, 1, 2) = -2.0*aks2*(sc*(1.0-sc)/akq2+ssok*ssok)/3.0
20754 t(2, 1, 6) = akq2*(ssok+al*sc)/2.0
20756 t(2, 2, 2) = -aks2*(2.0*ssok-2.0*ssok*sc)/(3.0*akq2)
20757 t(2, 2, 6) = t(1, 1, 6)
20759 t(2, 3, 3) = aks2*(2.0*bsok*bc+3.0*ssok)/5.0
20760 t(2, 3, 4) = 2.0*aks2*(bc*bc+bsok*bsok*akq2-sc)/(5.0*akq2)
20761 t(2, 4, 4) = 2.0*aks2*(bsok*bc-ssok)/(5.0*akq2)
20763 t(3, 1, 3) = 2.0*aks2*(bc*(1.0-sc)/akq2+2.0*ssok*bsok)/5.0
20764 t(3, 1, 4) = 2.0*aks2*(2.0*ssok*bc-bsok*(1.0+sc))/(5.0*akq2)
20765 t(3, 2, 3) = 2.0*aks2*(3.0*bsok-2.0*bsok*sc-ssok*bc)/(5.0*akq2)
20767 t(3, 2, 4) = 2.0*aks2*(2.0*bc*(1.0-sc)/akq2-ssok*bsok)/(5.0*akq2)
20768 t(3, 3, 6) = -al*akq2*bsok/2.0
20769 t(3, 4, 6) = (bsok-al*bc)/2.0
20771 t(4, 1, 3) = 2.0*aks2*(bsok*(1.0-sc)+bc*ssok+2.0*sc*bsok+2.0*ssok*bc)/5.0
20772 t(4, 1, 4) = 2.0*aks2*(2.0*sc*bc+2.0*ssok*bsok*akq2-bc*(1.0+sc)+bsok*ssok*akq2)/(5.0*akq2)
20773 t(4, 2, 3) = 2.0*aks2*(3.0*bc-2.0*bc*sc+2.0*bsok*ssok*akq2-sc*bc-ssok*bsok*akq2)/(5.0*akq2)
20774 t(4, 2, 4) = 2.0*aks2*(2.0*bsok*(1.0-sc)+2.0*bc*ssok-sc*bsok-ssok*bc)/(5.0*akq2)
20776 t(4, 3, 6) = -akq2*(bsok+al*bc)/2.0
20777 t(4, 4, 6) = t(3, 3, 6)
20779 t(5, 1, 1) = akq2*(al-sc*ssok)/4.0
20780 t(5, 1, 2) = -akq2*ssok*ssok/2.0
20781 t(5, 2, 2) = (al+sc*ssok)/4.0
20782 t(5, 3, 3) = -akq2*(al-bc*bsok)/4.0
20784 t(5, 3, 4) = akq2*(bsok*bsok)/2.0
20785 t(5, 4, 4) = (al+bc*bsok)/4.0
20794 implicit real *8(a-h, o-z)
20795 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
20796 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
20797 common /fene/wdisp, wphas, wx, wy, rlim, ifw
20798 common /dyn/tref, vref
20801 common /faisc/f(10, iptsz), imax, ngood
20802 common /etcom/cog(8), exten(17), fd(iptsz)
20803 common /qmoyen/qmoy
20804 common /consta/vl, pi, xmat, rpel, qst
20805 common /tapes/in, ifile, meta
20806 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
20807 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
20808 common /shif/dtiph, shift
20809 common /rander/ialin
20810 common /femt/iemgrw, iemqesg
20811 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
20812 common /compt/nrres, nrtre, nrbunc, nrdbun
20813 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
20814 common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
20815 common /bloc11/r(6, 6), t(6, 6, 6)
20816 dimension rs(6, 6), rcul(6, 6)
20817 logical iesp, ichaes, shift, ialin, iemgrw
20822 write (6, 8254) nrtre, nrres, cr
20823 8254
format (
'Transport element:', i5,
' Accelerating element:', i5, a1, $)
20832 read (25, *) xspl(i), yspl(i)
20839 dsol = (zsup-zinf)/float(npas)
20840 xlsol = (zsup-zinf)*100.
20841 write (16, 101) xlsol,
crest, bcret
20842 101
format (5x,
'Field length =', f7.3,
' cm ', /, 5x,
'Crest of the field =', f10.4,
' kG', /5x, &
20843 'Attenuation factor =', f10.4, /)
20850 if (iprf==1)
call stapl(davtot*10.)
20854 dav1(idav, 1) = xlsol*10.
20855 dav1(idav, 2) =
crest 20857 davtot = davtot + xlsol
20858 dav1(idav, 4) = davtot*10.
20863 if (ia==ib) rcul(ia, ib) = 1.
20864 if (ia/=ib) rcul(ia, ib) = 0.
20869 fnpas = float(npas)
20872 zcf2 = zc + dsol/2.
20873 bsol = bcret*
spline(ncord, zcf2)
20876 tref = tref + xlsol/(vref*fnpas)
20878 write (16, 520) i, zc, zcf, bsol
20879 520
format (2x,
'**STEP: ', i2,
' LIMITS: inf(m)= ', f7.5,
' sup(m)= ', f7.5,
' AVERAGE FIELD(kG): ', e12.5)
20880 bisol = bisol + bsol*dsol
20881 bisol2 = bisol2 + bsol*bsol*dsol
20885 rs(ia, ib) = rcul(ia, ib)
20903 if (.not. iesp)
then 20907 if (ichaes .and. xlsol>0.)
then 20908 if (sce10==1 .or. sce10==3.)
then 20918 write (16, *)
'distance', davti, dsol
20919 davti = davti + dsol*100.
20920 call stapl((davti)*10.)
20923 write (16, 922) zc, bisol, bisol2, bisol2/zc
20924 922
format (/,
'Field length (m): ', e12.5, /,
'Field integral (kG.m): ', e12.5, /, &
20925 'Field squared integral (kG**2.m): ', e12.5, /,
'Field squared integral/L (kG**2): ', e12.5, /)
20928 write (16, *)
' EQUIVALENT FIRST order MATRIX TRANSFORM (m-rad)' 20929 skl = 0.5*acos(2.*rcul(1,1)-1.)*57.29578
20930 write (16, *)
' ******* K*LENGTH: ', skl,
' degrees' 20932 write (16, 100)(rcul(ia,ib), ib=1, 6)
20934 100
format (6(3x,e12.5))
20938 dav1(idav, 36) = ngood
20940 call stapl(davtot*10.)
20941 if (iemgrw)
call emiprt(0)
20942 write (16, *)
'particles lost in solenoid', ilost
20949 subroutine fldsol(dbs, step)
20950 implicit real *8(a-h, o-z)
20951 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
20952 common /faisc/f(10, iptsz), imax, ngood
20953 common /fene/wdisp, wphas, wx, wy, rlim, ifw
20954 common /consta/vl, pi, xmat, rpel, qst
20955 common /etcom/cog(8), exten(17), fd(iptsz)
20956 common /femt/iemgrw, iemqesg
20957 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
20958 common /sole/l, kl, ko
20965 gpai = gpai + f(7, ii)/xmat
20967 gpai = gpai/float(ngood)
20968 bpai = sqrt(1.-1./(gpai*gpai))
20969 xmco = xmat*bpai*gpai
20970 ri = 33.356*xmco*1.e-01/qst
20972 if (ko==0.) ko = 1.e-16
21010 subroutine solnoid(imks, arg, xlsol)
21011 implicit real *8(a-h, o-z)
21012 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
21013 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
21014 common /fene/wdisp, wphas, wx, wy, rlim, ifw
21015 common /dyn/tref, vref
21018 common /faisc/f(10, iptsz), imax, ngood
21019 common /etcom/cog(8), exten(17), fd(iptsz)
21020 common /qmoyen/qmoy
21021 common /consta/vl, pi, xmat, rpel, qst
21022 common /tapes/in, ifile, meta
21023 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
21024 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
21025 common /shif/dtiph, shift
21026 common /rander/ialin
21027 common /femt/iemgrw, iemqesg
21028 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
21029 common /compt/nrres, nrtre, nrbunc, nrdbun
21030 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
21031 common /bloc11/r(6, 6), t(6, 6, 6)
21032 common /itvole/itvol, imamin
21033 common /tofev/ttvols
21034 common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
21035 character *128 trace3h, trace3t, tif
21036 logical itvol, imamin
21038 logical iesp, ichaes, shift, ialin, iemgrw
21040 common /sole/l, kl, ko
21046 write (6, 8254) nrtre, nrres, cr
21047 8254
format (
'Transport element:', i5,
' Accelerating element:', i5, a1, $)
21048 write (16, *)
' ****** SOLENOID *********' 21050 if (iprf==1)
call stapl(davtot*10.)
21059 gpa = gpa + f(7, ii)/xmat
21061 gpa = gpa/float(ngood)
21063 bpa = sqrt(1.-1./(gpa*gpa))
21064 xmco = xmat*bpa*gpa
21065 ri = 33.356*xmco*1.e-01/qst
21071 if (ko==0.) ko = 1.e-16
21076 if (ko==0.) ko = 1.e-16
21082 xkql = (kl/2.)*57.29578
21085 write (tif, 6002) kt3t, kt3t, b*1000., 10.*xlsol
21086 6002
format (
' nt(', i4,
')= 5, a(1,', i4,
')= ', f12.5,
' , ', f9.5)
21087 trace3t(kt3t) = tif
21089 write (16, 101) xlsol, b, ko/2., ri, xkql
21090 101
format (
' LENGTH = ', f7.3,
' CM ', /,
' FIELD = ', f10.4,
' KG', /,
' K = ', e12.5,
' cm-1', /, &
21091 ' MOMENTUM = ', e12.5,
' kG.cm', /,
' TRANSVERSE COORDINATES ROTATION = ', e12.5,
' deg', /)
21093 write (16, 10) ttvols*fcpi, davtot
21094 10
format (
' ** time of flight (input): ', e12.5,
' deg position: ', e12.5,
' cm')
21098 dav1(idav, 1) = xlsol*10.
21100 dav1(idav, 3) = ko/2.
21101 davtot = davtot + xlsol
21102 dav1(idav, 4) = davtot*10.
21109 gpai = f(7, ii)/xmat
21110 bpai = sqrt(1.-1./(gpai*gpai))
21111 xmco = xmat*bpai*gpai
21112 ri = 33.356*xmco*1.e-01/f(9, ii)
21114 if (ko==0.) ko = 1.e-16
21122 if (ichaes .and. l>0.)
then 21123 if (sce10==1 .or. sce10==3.)
then 21125 write (16, *)
'space charge at the middle ' 21136 gpai = f(7, i)/xmat
21137 bcour = sqrt(1.-1./(gpai*gpai)) + bcour
21139 bcour = bcour/float(ngood)
21140 gcour = 1./sqrt(1.-bcour*bcour)
21141 wcg = (gcour-1.)*xmat
21143 tref = tref + xlsol/(vref*2.)
21150 gpai = f(7, ii)/xmat
21151 bpai = sqrt(1.-1./(gpai*gpai))
21152 xmco = xmat*bpai*gpai
21153 ri = 33.356*xmco*1.e-01/f(9, ii)
21155 if (ko==0.) ko = 1.e-16
21161 tref = tref + xlsol/(vref*2.)
21163 if (itvol) ttvols = tref
21166 tcog = tcog + f(6, i)
21168 tcog = tcog/float(ngood)
21170 write (16, 11) ttvols*fcpi, davtot, tref*fcpi, tcog*fcpi
21171 11
format (
' ** tof for adjustments: ', e12.5,
' deg at position: ', e12.5,
' cm in the lattice', /, 3x, &
21172 'tof of the reference: ', e12.5,
' deg tof of the cog: ', e12.5,
' deg')
21174 write (16, 12) tref*fcpi, tcog*fcpi
21175 12
format (
' ** tof of the reference: ', e12.5,
' deg tof of the cog: ', e12.5,
' deg')
21177 dav1(idav, 36) = ngood
21179 call stapl(davtot*10.)
21180 if (iemgrw)
call emiprt(0)
21181 write (16, *)
'particles lost in solenoid', ilost
21189 implicit real *8(a-h, o-z)
21190 common /sole/l, kl, ko
21193 common /bloc11/r(6, 6), t(6, 6, 6)
21194 common /secdr/iseor
21205 r(4, 4) = 0.5 + 0.5*cs
21209 r(1, 4) = (1.-cs)/ko
21211 r(4, 1) = 0.25*ko*(1.-cs)
21217 r(3, 4) = r(1, 3)*2./ko
21219 r(4, 3) = -0.25*ko*sn
21223 if (.not. iseor)
go to 200
21229 t(1, 2, 6) = sn/ko - l*cs
21230 t(3, 4, 6) = t(1, 2, 6)
21231 temp = -0.5*ko*l*cs
21236 t(1, 4, 6) = (1.0-cs)/ko - l*sn
21237 t(3, 2, 6) = -t(1, 4, 6)
21238 t(2, 1, 6) = 0.25*ko*(ko*l*cs+sn)
21239 t(4, 3, 6) = t(2, 1, 6)
21240 t(2, 3, 6) = 0.25*ko*(1.0-cs+ko*l*sn)
21241 t(4, 1, 6) = -t(2, 3, 6)
21255 end subroutine elsol 21260 subroutine mfordre(rc, ra, rb)
21261 implicit real *8(a-h, o-z)
21262 dimension ra(6, 6), rb(6, 6), rc(6, 6)
21268 ghost = ghost + ra(i1, i3)*rb(i3, i2)
21293 subroutine solquad(iksq, args, argq, xlsol, rg)
21294 implicit real *8(a-h, o-z)
21295 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
21296 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
21297 common /fene/wdisp, wphas, wx, wy, rlim, ifw
21298 common /dyn/tref, vref
21301 common /faisc/f(10, iptsz), imax, ngood
21302 common /etcom/cog(8), exten(17), fd(iptsz)
21303 common /qmoyen/qmoy
21304 common /consta/vl, pi, xmat, rpel, qst
21305 common /tapes/in, ifile, meta
21306 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
21307 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
21308 common /shif/dtiph, shift
21309 common /rander/ialin
21310 common /femt/iemgrw, iemqesg
21311 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
21312 common /compt/nrres, nrtre, nrbunc, nrdbun
21313 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
21315 logical iesp, shift, ialin, iemgrw
21317 common /slq/l, kso, kqo
21318 real *8 l, kso, kqo
21322 write (6, 8254) nrtre, nrres, cr
21323 8254
format (
'Transport element:', i5,
' Accelerating element:', i5, a1, $)
21326 if (iprf==1)
call stapl(davtot*10.)
21333 gpa = gpa + f(7, ii)/xmat
21335 gpa = gpa/float(ngood)
21337 bpa = sqrt(1.-1./(gpa*gpa))
21338 xmco = xmat*bpa*gpa
21339 ri = 33.356*xmco*1.e-01/qst
21364 xksl = xks*l*57.29578
21365 write (16, *)
'****SOLENOID+QUADRUPOLE*******' 21366 write (16, 101) xlsol, rg, bs, strs, xksl, fq, strq, ri
21367 101
format (
' LENGTH =', f7.3,
' cm APERTURE RADIUS=', e12.5,
' cm', /,
' SOLENOID: FIELD = ', f10.4,
' kG K = ', &
21368 e12.5,
' cm-1 ROTATING ANGLE = ', e12.5,
' deg', /,
' QUADRUPOLE: FIELD =', f10.4,
' kG K2 =', e12.5, &
21369 ' cm-2 ', /,
' RIGIDITY = ', e12.5,
' kG.cm', /)
21374 write (16, *)
' The matrix R and T are shown for a positive strength' 21375 write (16, *)
' For a negative strength set up 90 deg rotation on the beam' 21380 dav1(idav, 1) = xlsol*10.
21383 dav1(idav, 5) = strq
21384 dav1(idav, 6) = kso/2.
21385 dav1(idav, 7) = rg*10.
21387 davtot = davtot + xlsol
21388 dav1(idav, 4) = davtot*10.
21394 gpai = f(7, ii)/xmat
21395 bpai = sqrt(1.-1./(gpai*gpai))
21396 xmco = xmat*bpai*gpai
21397 ri = 33.356*xmco*1.e-01/f(9, ii)
21400 if (kso==6.*0) kso = 1.e-16
21417 if (ichaes .and. l>0.)
then 21418 if (sce10==1 .or. sce10==3.)
then 21420 write (16, *)
'space charge at the middle ' 21431 gpai = f(7, i)/xmat
21432 bcour = sqrt(1.-1./(gpai*gpai)) + bcour
21434 bcour = bcour/float(ngood)
21435 gcour = 1./sqrt(1.-bcour*bcour)
21436 wcg = (gcour-1.)*xmat
21438 tref = tref + xlsol/(2.*vref)
21445 gpai = f(7, ii)/xmat
21446 bpai = sqrt(1.-1./(gpai*gpai))
21447 xmco = xmat*bpai*gpai
21448 ri = 33.356*xmco*1.e-01/f(9, ii)
21451 if (kso==0.) kso = 1.e-16
21467 tref = tref + xlsol/(vref*2.)
21469 dav1(idav, 36) = ngood
21471 call stapl(davtot*10.)
21472 if (iemgrw)
call emiprt(0)
21473 write (16, *)
'particles lost in solenoid', ilost
21480 subroutine rotat(ii)
21481 implicit real *8(a-h, o-z)
21482 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
21483 common /faisc/f(10, iptsz), imax, ngood
21509 end subroutine rotat 21518 implicit real *8(a-z)
21520 common /slq/l, kso, kqo
21521 common /bloc11/r(6, 6), t(6, 6, 6)
21522 common /secdr/iseor
21533 q2 = dsqrt(akq4+4.0*aks4)
21535 sk1 = sqrt(2.0*aks2+q2)
21536 sk3 = sqrt(abs(q2-2.0*aks2))
21541 skp = 0.5*(sk1+sk3)
21542 skm = 0.5*(sk1-sk3)
21547 r(1, 1) = q2i*(skp2*sc+skm2*bc)
21548 r(1, 2) = q2i*(skp*ss-skm*bs)
21549 r(1, 3) = q2i*aks*(skm*ss+skp*bs)
21550 r(1, 4) = q2i*aks*(bc-sc)
21551 r(2, 1) = q2i*(-skp3*ss-skm3*bs)
21552 r(2, 2) = q2i*(skp2*sc+skm2*bc)
21553 r(2, 3) = q2i*aks3*(sc-bc)
21554 r(2, 4) = q2i*aks*(skp*ss-skm*bs)
21555 r(3, 1) = q2i*aks*(skm*bs-skp*ss)
21556 r(3, 2) = q2i*aks*(sc-bc)
21557 r(3, 3) = q2i*(skm2*sc+skp2*bc)
21558 r(3, 4) = q2i*(skm*ss+skp*bs)
21559 r(4, 1) = q2i*aks3*(bc-sc)
21560 r(4, 2) = q2i*aks*(-skm*ss-skp*bs)
21561 r(4, 3) = q2i*(skp3*bs-skm3*ss)
21562 r(4, 4) = q2i*(skm2*sc+skp2*bc)
21563 if (.not. iseor)
return 21566 dakq4 = 2.0*akq*dakq
21567 daks2 = 2.0*aks*daks
21568 daks3 = 3.0*aks2*daks
21569 daks4 = 4.0*aks3*daks
21570 dq2 = 0.5*q2i*(dakq4+4.0*daks4)
21573 dsk1 = (2.0*daks2+dq2)/(2.0*sk1)
21575 if (sk3/=6.*0) dsk3 = (dq2-2.0*daks2)/(2.0*sk3)
21580 dskp = 0.5*(dsk1+dsk3)
21581 dskm = 0.5*(dsk1-dsk3)
21582 dskp2 = 2.0*skp*dskp
21583 dskp3 = 3.0*skp2*dskp
21584 dskm2 = 2.0*skm*dskm
21585 dskm3 = 3.0*skm2*dskm
21586 t(1, 1, 6) = dq2i*(skp2*sc+skm2*bc) + q2i*(dskp2*sc+skp2*dsc+dskm2*bc+skm2*dbc)
21587 t(1, 2, 6) = dq2i*(skp*ss-skm*bs) + q2i*(dskp*ss+skp*dss-dskm*bs-skm*dbs)
21588 t(1, 3, 6) = (dq2i*aks+q2i*daks)*(skm*ss+skp*bs) + q2i*aks*(dskm*ss+skm*dss+dskp*bs+skp*dbs)
21589 t(1, 4, 6) = (dq2i*aks+q2i*daks)*(bc-sc) + q2i*aks*(dbc-dsc)
21590 t(2, 1, 6) = dq2i*(-skp3*ss-skm3*bs) + q2i*(-dskp3*ss-skp3*dss-dskm3*bs-skm3*dbs)
21591 t(2, 2, 6) = t(1, 1, 6)
21592 t(2, 3, 6) = (dq2i*aks3+q2i*daks3)*(sc-bc) + q2i*aks3*(dsc-dbc)
21593 t(2, 4, 6) = (dq2i*aks+q2i*daks)*(skp*ss-skm*bs) + q2i*aks*(dskp*ss+skp*dss-dskm*bs-skm*dbs)
21594 t(3, 1, 6) = -t(2, 4, 6)
21595 t(3, 2, 6) = -t(1, 4, 6)
21596 t(3, 3, 6) = dq2i*(skm2*sc+skp2*bc) + q2i*(dskm2*sc+skm2*dsc+dskp2*bc+skp2*dbc)
21597 t(3, 4, 6) = dq2i*(skm*ss+skp*bs) + q2i*(dskm*ss+skm*dss+dskp*bs+skp*dbs)
21598 t(4, 1, 6) = -t(2, 3, 6)
21600 t(4, 2, 6) = -t(1, 3, 6)
21601 t(4, 3, 6) = dq2i*(skp3*bs-skm3*ss) + q2i*(dskp3*bs+skp3*dbs-dskm3*ss-skm3*dss)
21602 t(4, 4, 6) = t(3, 3, 6)
21604 if (sk1/=0.0) aisssc = ss*ss/(2.0*sk1)
21606 if (sk3/=0.0) aibsbc = bs*bs/(2.0*sk3)
21607 aissbc = q2i*(sk3*ss*bs-sk1*sc*bc+sk1)
21608 aiscbs = q2i*(sk3*sc*bc+sk1*ss*bs-sk3)
21613 if (sk1/=0.0) aiss2 = 0.5*(al-ss*sc/sk1)
21614 if (sk1/=0.0) aisc2 = 0.5*(al+ss*sc/sk1)
21615 if (sk3/=0.0) aibs2 = 0.5*(bs*bc/sk3-al)
21616 if (sk3/=0.0) aibc2 = 0.5*(al+bs*bc/sk3)
21617 aissbs = q2i*(sk3*ss*bc-sk1*sc*bs)
21618 aiscbc = q2i*(sk1*ss*bc+sk3*sc*bs)
21628 t(5, 1, 1) = q4i*0.5*(skp6*aiss2+skm6*aibs2-2.0*skp3*skm3*aissbs+aks6*(aisc2+aibc2-2.0*aiscbc))
21629 t(5, 1, 2) = q4i*(-skp5*aisssc-skp3*skm2*aissbc-skm3*skp2*aiscbs-skm5*aibsbc-aks4*(-skm*aisssc-skp*aiscbs+skm* &
21630 aissbc+skp*aibsbc))
21631 t(5, 1, 3) = q4i*aks3*((skp3-skm3)*(aissbc-aisssc)+(skp3+skm3)*(aibsbc-aiscbs))
21632 t(5, 1, 4) = q4i*(aks*(-skp4*aiss2-(skp3*skm+skm3*skp)*aissbs+skm4*aibs2)+aks3*(-skm2*aisc2-(skp2-skm2)*aiscbc+ &
21634 t(5, 2, 2) = q4i*0.5*(skp4*aisc2+2.0*skp2*skm2*aiscbc+skm4*aibc2+aks2*(skm2*aiss2+2.0*skp*skm*aissbs+skp2*aibs2))
21635 t(5, 2, 3) = q4i*(aks3*(skp2*aisc2-(skp2-skm2)*aiscbc-skm2*aibc2)-aks*(-skm4*aiss2+(skm*skp3- &
21636 skp*skm3)*aissbs+skp4*aibs2))
21637 t(5, 2, 4) = q4i*aks*((skp3-skm3)*aisssc-(skp2*skm+skp*skm2)*aiscbs+(skm2*skp-skm*skp2)*aissbc-(skm3+skp3)*aibsbc)
21638 t(5, 3, 3) = q4i*0.5*(aks6*(aisc2-2.0*aiscbc+aibc2)+skm6*aiss2-2.0*skm3*skp3*aissbs+skp6*aibs2)
21639 t(5, 3, 4) = q4i*(aks4*(skp*aisssc-skm*aiscbs-skp*aissbc+skm*aibsbc)-skm5*aisssc-skm3*skp2*aissbc+skp3*skm2*aiscbs &
21641 t(5, 4, 4) = q4i*0.5*(aks2*(skp2*aiss2-2.0*skp*skm*aissbs+skm2*aibs2)+skm4*aisc2+2.0*skm2*skp2*aiscbc+skp4*aibc2)
21643 end subroutine elsq 21649 subroutine fdrift(xl, npart, imit)
21650 implicit real *8(a-h, o-z)
21652 dl = xl/float(npart)
21655 if (imit/=0.)
call emiprt(0)
21664 subroutine drift(dl)
21665 implicit real *8(a-h, o-z)
21666 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
21668 common /consta/vl, pi, xmat, rpel, qst
21669 common /dyn/tref, vref
21670 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
21671 common /faisc/f(10, iptsz), imax, ngood
21672 common /tapes/in, ifile, meta
21673 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
21674 common /etcom/cog(8), exten(17), fd(iptsz)
21675 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
21676 common /fene/wdisp, wphas, wx, wy, rlim, ifw
21678 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
21679 common /shif/dtiph, shift
21680 common /femt/iemgrw, iemqesg
21682 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
21683 common /tofev/ttvols
21684 common /itvole/itvol, imamin
21685 logical iesp, ichaes, shift, iemgrw, itvol, imamin
21690 write (16, *)
'*** DRIFT of length ', dl,
' cm' 21691 if (itvol)
write (16, 10) ttvols*fcpi, davtot
21692 10
format (
' ** tof for adjustments at input: ', e12.5,
' deg at position: ', e12.5,
' cm in the lattice')
21694 if (iprf==1)
call stapl(davtot*10.)
21702 f(2, i) = f(2, i) + dg2*tan(f2)
21703 f(4, i) = f(4, i) + dg2*tan(f4)/cos(f2)
21704 gpai = f(7, i)/xmat
21705 bpai = sqrt(1.-1./(gpai*gpai))
21707 f(6, i) = f(6, i) + dg2/(vpai*cos(f2)*cos(f4))
21711 davtot = davtot + dl
21716 dav1(idav, 1) = dl*10.
21717 dav1(idav, 4) = davtot*10.
21720 if (ichaes .and. dl>=1.e-04)
then 21721 if (sce10==3.)
then 21723 write (16, *)
' space charge at the middle' 21731 tref = tref + dl/(vref*2.)
21740 f(2, i) = f(2, i) + dg2*tan(f2)
21741 f(4, i) = f(4, i) + dg2*tan(f4)/cos(f2)
21742 gpai = f(7, i)/xmat
21743 bpai = sqrt(1.-1./(gpai*gpai))
21745 f(6, i) = f(6, i) + dg2/(vpai*cos(f2)*cos(f4))
21748 tref = tref + dl/(vref*2.)
21752 if (itvol) ttvols = tref
21754 dav1(idav, 36) = ngood
21756 call stapl(davtot*10.)
21760 tcog = tcog + f(6, i)
21762 tcog = tcog/float(ngood)
21764 write (16, 11) ttvols*fcpi, davtot, tref*fcpi, tcog*fcpi
21765 11
format (
' ** tof for adjustments : ', e12.5,
' deg at position: ', e12.5,
' cm in the lattice', /, 3x, &
21766 'tof of the reference: ', e12.5,
' deg tof of the cog: ', e12.5,
' deg')
21768 write (16, 12) tref*fcpi, tcog*fcpi
21769 12
format (
' ** tof of the reference: ', e12.5,
' deg tof of the cog: ', e12.5,
' deg')
21771 write (16, *)
'particles lost in drift: ', il
21772 if (iemgrw .and. dl>0.)
then 21773 if (iemqesg==2)
call emiprt(0)
21776 end subroutine drift 21779 implicit real *8(a-h, o-z)
21780 common /bloc11/r(6, 6), t(6, 6, 6)
21781 common /secdr/iseor
21787 if (ia==ib) r(ia, ib) = 1.
21801 end subroutine clear 21806 subroutine cobeam(ii, xl)
21807 implicit real *8(a-h, o-z)
21808 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
21809 common /faisc/f(10, iptsz), imax, ngood
21810 common /bloc11/r(6, 6), t(6, 6, 6)
21811 common /etcom/cog(8), exten(17), fd(iptsz)
21812 common /consta/vl, pi, xmat, rpel, qst
21813 common /radia/trt, rmoy, xintf, crae
21814 common /secdr/iseor
21816 dimension sf(6), ssf(6)
21819 sf(1) = f(2, ii)*1.e-02
21820 sf(2) = f(3, ii)*1.e-03
21821 sf(3) = f(4, ii)*1.e-02
21822 sf(4) = f(5, ii)*1.e-03
21824 sf(5) = sf(5)/(cos(sf(2))*cos(sf(4)))
21825 sf(6) = (fd(ii)-1.)
21830 ssf(ia) = r(ia, ib)*sf(ib) + ssf(ia)
21833 if (.not. iseor)
go to 10
21838 ssf(ia) = ssf(ia) + t(ia, ib, ic)*sf(ib)*sf(ic)
21844 f(ia+1, ii) = ssf(ia)
21847 f(3, ii) = f(3, ii)*1000.
21848 f(5, ii) = f(5, ii)*1000.
21849 f(2, ii) = f(2, ii)*100.
21850 f(4, ii) = f(4, ii)*100.
21851 gpai = f(7, ii)/xmat
21852 bpai = sqrt(1.-1./(gpai*gpai))
21854 trt = 100.*ssf(5)/vpai
21855 f(6, ii) = f(6, ii) + trt
21864 implicit real *8(a-h, o-z)
21865 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
21866 common /faisc/f(10, iptsz), imax, ngood
21867 common /etcom/cog(8), exten(17), fd(iptsz)
21868 common /mcs/imcs, ncstat, cstat(20)
21869 common /consta/vl, pi, xmat, rpel, qst
21873 gcog = f(7, i)/xmat + gcog
21875 gcog = gcog/float(ngood)
21876 bcog = sqrt(1.-1./(gcog*gcog))
21878 gpai = f(7, i)/xmat
21880 bpai = sqrt(1.-1./(gpai*gpai))
21884 fd(i) = bpai/bcog*gpai/gcog
21887 end subroutine disp 21917 implicit real *8(a-h, o-z)
21918 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
21919 common /faisc/f(10, iptsz), imax, ngood
21920 common /grot/rzot, izrot
21921 common /consta/vl, pi, xmat, rpel, qst
21922 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
21924 dimension rs(6, 6), ff(6), fc(6)
21926 write (16, 100) zrot
21927 100
format (/, 20x,
'BEAM ROTATION ', f10.4,
' degrees ABOUT THE POSITIVE Z-AXIS', /)
21928 if (.not. izrot)
then 21933 if (izrot) izrot = .false.
21938 dav1(idav, 1) = zrot
21946 zrot = zrot*pi/180.
21965 fc(ia) = fc(ia) + ff(ib)*rs(ia, ib)
21984 implicit real *8(a-h, o-z)
21985 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
21986 common /faisc/f(10, iptsz), imax, ngood
21987 common /grot/rzot, izrot
21988 common /consta/vl, pi, xmat, rpel, qst
21990 dimension rs(6, 6), ff(6), fc(6)
21992 write (16, 100) zrot
21993 100
format (/, 20x,
'BEAM ROTATION ', f10.4,
' degrees ABOUT THE POSITIVE Z-AXIS', /)
21996 zrot = zrot*pi/180.
22015 fc(ia) = fc(ia) + ff(ib)*rs(ia, ib)
22032 implicit real *8(a-h, o-z)
22033 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
22034 common /alin/xl, yl, xpl, ypl
22035 common /faisc/f(10, iptsz), imax, ngood
22037 write (16, 100) xl, yl, xpl, ypl
22038 100
format (/, 5x,
' KICK x(cm) y(cm) : ', 2(e12.5,2x), /, 5x,
' KICK xp(mrad) yp(mrad): ', 2(e12.5,2x), //)
22042 f(2, ii) = f(2, ii) + xl
22043 f(4, ii) = f(4, ii) + yl
22044 f(3, ii) = f(3, ii) + xpl
22045 f(5, ii) = f(5, ii) + ypl
22056 implicit real *8(a-h, o-z)
22057 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
22058 common /alin/xl, yl, xpl, ypl
22059 common /faisc/f(10, iptsz), imax, ngood
22063 write (16, *)
' random error in alignment with:' 22064 write (16, 100) xl, yl, xpl, ypl
22065 100
format (/, 5x,
' KICK x(cm) y(cm) : ', 2(e12.5,2x), /, 5x,
' KICK xp(mrad) yp(mrad): ', 2(e12.5,2x), //)
22068 call rlux(trans, len)
22069 if (trans(1)<=rdcf) sign = -1.
22070 if (trans(1)>rdcf) sign = 1.
22071 call rlux(trans, len)
22072 xla = xl*sign*trans(1)
22073 call rlux(trans, len)
22074 if (trans(1)<=rdcf) sign = -1.
22075 if (trans(1)>rdcf) sign = 1.
22076 call rlux(trans, len)
22077 yla = yl*sign*trans(1)
22078 call rlux(trans, len)
22079 if (trans(1)<=rdcf) sign = -1.
22080 if (trans(1)>rdcf) sign = 1.
22081 call rlux(trans, len)
22082 xpla = xpl*sign*trans(1)
22083 call rlux(trans, len)
22084 if (trans(1)<=rdcf) sign = -1.
22085 if (trans(1)>rdcf) sign = 1.
22086 call rlux(trans, len)
22087 ypla = ypl*sign*trans(1)
22088 write (16, 100) xla, yla, xpla, ypla
22090 f(2, ii) = f(2, ii) + xla
22091 f(4, ii) = f(4, ii) + yla
22092 f(3, ii) = f(3, ii) + xpla
22093 f(5, ii) = f(5, ii) + ypla
22102 implicit real *8(a-h, o-z)
22103 common /bloc11/r(6, 6), t(6, 6, 6)
22104 common /secdr/iseor
22107 write (16, *)
' TRANSPORT MATRIX (m-rd)' 22108 write (16, *)
' FIRST ORDER TRANSPORT********' 22110 write (16, 100)(r(ia,ib), ib=1, 6)
22112 100
format (6(3x,e12.5))
22113 write (16, *)
' *************************************************' 22115 write (16, *)
' SECOND ORDER TRANSPORT (m-rd)********' 22119 if (t(ia,ib,ic)/=6.*0)
write (16, 101) ia, ib, ic, t(ia, ib, ic)
22123 write (16, *)
' *************************************************' 22125 101
format (
' T', 3(i1), 3x, e12.5)
22134 subroutine egun(fmult, indp)
22135 implicit real *8(a-h, o-z)
22136 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
22137 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
22138 common /faisc/f(10, iptsz), imax, ngood
22139 common /consta/vl, pi, xmat, rpel, qst
22140 common /azlist/icont, iprin
22141 common /dyn/tref, vref
22143 common /etcom/cog(8), exten(17), fd(iptsz)
22144 common /qmoyen/qmoy
22145 common /tapes/in, ifile, meta
22146 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
22147 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
22148 common /femt/iemgrw, iemqesg
22149 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
22150 common /compt/nrres, nrtre, nrbunc, nrdbun
22151 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
22153 common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
22154 dimension gam(3000), xe(3000), xpe(3000), ye(3000), ype(3000)
22156 logical flgsc, iesp, ichaes, iemgrw
22160 write (6, 8254) nrtre, nrres
22161 8254
format (
'Transport element:', i5,
' Accelerating element:', i5)
22162 write (6, *)
'EGUN calculation started' 22168 we = we/float(ngood) - xmat
22173 if (indp>3) indp = 3
22174 if (indp==1) ipart = 16
22175 if (indp>=2) ipart = 32
22176 if (indp==3) ipart = 64
22181 if (we<=weinf)
then 22182 write (6, *)
' Energy at the cathode: ', we,
' eV is below the lower limit of 20 eV ' 22190 read (22, *) xspl(i), yspl(i)
22198 if (iprf==1)
call stapl(davtot*10.)
22203 dav1(idav, 1) = egl*1000.
22204 dav1(idav, 2) = fmult
22205 davtot = davtot + elgun
22206 dav1(idav, 4) = elgun*10.
22209 eglp = egl/float(ipart)
22211 scl = float(ipart)/2.
22212 eglsc = egl*100./scl
22215 xpas = eglp/float(npas)
22220 tspl =
spline(npt, fpos)*fmult
22221 dcfld = dcfld + qst*tspl*xpas
22225 dav1(idav, 3) = dcfld*1000.
22226 write (16, 101) elgun, fmult, dcfld*1000.
22227 101
format (5x,
' FIELD LENGTH =', f7.3,
' CM ', /, 5x,
' FIELD CREST=', f10.4,
' MV/m', /5x,
' FIELD STENGTH= ', &
22237 if (we<swe1) npas = 400
22238 if (we<swe2) npas = 300
22240 xpas = xlstart/float(npas)
22246 if (iflg==ipart)
go to 500
22254 x0 = f(2, j)*1.e-02
22255 y0 = f(4, j)*1.e-02
22256 t0 = f(3, j)*1.e-03
22257 p0 = f(5, j)*1.e-03
22259 xe0 = x0*(gam0*gam0-1.)**0.25
22260 xpe0 = t0*(gam0*gam0-1.)**0.25
22261 ye0 = y0*(gam0*gam0-1.)**0.25
22262 ype0 = p0*(gam0*gam0-1.)**0.25
22264 tspl =
spline(npt, fpos)*fmult
22265 dgam = (qc/e0)*tspl
22267 xpe0 = xpe0 + .5*xe0*gam0*dgam/(gam0*gam0-1)
22268 ype0 = ype0 + .5*ye0*gam0*dgam/(gam0*gam0-1)
22269 a1 = qc*qc/(4.*e0*e0)
22278 fpos2 = (xnh+0.25)*xpas
22279 fpos3 = (xnh+0.5)*xpas
22280 fpos4 = (xnh+0.75)*xpas
22281 fpos5 = (xnh+1.)*xpas
22282 tspl1 =
spline(npt, fpos1)*fmult
22283 tspl2 =
spline(npt, fpos2)*fmult
22284 tspl3 =
spline(npt, fpos3)*fmult
22285 tspl4 =
spline(npt, fpos4)*fmult
22286 tspl5 =
spline(npt, fpos5)*fmult
22287 cw = (qc/e0)*xpas/90.
22288 tspl = 7.*tspl1 + 32.*tspl2 + 12.*tspl3 + 32.*tspl4 + 7.*tspl5
22289 gam(i) = cw*tspl + gam(i1)
22292 dgam1 = (qc/e0)*tspl1
22293 cof1 = (gam5-gam1)/(xpas*xpas)
22296 gam2 = gam1 + dgam1*xpas/4. + cof*xpas*xpas/16.
22297 gam3 = gam1 + dgam1*xpas*0.5 + cof*xpas*xpas/4.
22298 gam4 = gam1 + dgam1*xpas*0.75 + cof*9.*xpas*xpas/16.
22305 bgt2 = (gams2-1.)**1.5
22306 bgt3 = (gams3-1.)**1.5
22307 bgt4 = (gams4-1.)**1.5
22308 bgt5 = (gams5-1.)**1.5
22309 tslpt = 8.*tspl2/bgt2 + 6.*tspl3/bgt3 + 24.*tspl4/bgt4 + 7.*tspl5/bgt5
22310 dt = a2*xpas*xpas*tslpt/90.
22311 bet = sqrt(1.-1./gams1)
22312 tof = tof + xpas/(vlm*bet) + dt
22313 f(7, j) = gam(i)*e0
22315 bg1 = (gams1+2.)/((gams1-1.)*(gams1-1.))
22316 bg2 = (gams2+2.)/((gams2-1.)*(gams2-1.))
22317 bg3 = (gams3+2.)/((gams3-1.)*(gams3-1.))
22318 bg4 = (gams4+2.)/((gams4-1.)*(gams4-1.))
22319 bg5 = (gams5+2.)/((gams5-1.)*(gams5-1.))
22320 bgts1 = bg1*tspl1*tspl1
22321 bgts2 = bg2*tspl2*tspl2
22322 bgts3 = bg3*tspl3*tspl3
22323 bgts4 = bg4*tspl4*tspl4
22324 bgts5 = bg5*tspl5*tspl5
22326 gtpm = 7.*bgts1 + 32.*bgts2 + 12.*bgts3 + 32.*bgts4 + 7.*bgts5
22328 gtm = 7.*bgts1 + 24.*bgts2 + 6.*bgts3 + 8.*bgts4
22330 gtpz = 8.*bgts2 + 6.*bgts3 + 24.*bgts4 + 7.*bgts5
22331 gtm1 = 2.*bgts2 + 3.*bgts3 + 18.*bgts4 + 7.*bgts5
22332 de = -a1*xpas*xpas*gtm/90.
22333 de1 = -a1*xpas*xpas*xpas*gtm1/90.
22334 dpe1 = -a1*xpas*gtpm/90.
22335 dpe2 = -a1*xpas*xpas*gtpz/90.
22336 dxpe1 = dpe1*xe(i1)
22337 dype1 = dpe1*ye(i1)
22338 dxpe2 = dpe2*xpe(i1)
22339 dype2 = dpe2*ype(i1)
22340 dxe = de*xe(i1) + de1*xpe(i1)
22341 dye = de*ye(i1) + de1*ype(i1)
22342 xpe(i) = xpe(i1) + dxpe1 + dxpe2
22343 ype(i) = ype(i1) + dype1 + dype2
22344 xe(i) = xe(i1) + dxe + xpe(i1)*xpas
22345 ye(i) = ye(i1) + dye + ype(i1)*xpas
22347 gamm1 = (gams5-1.)**0.25
22348 gamm2 = (gams5-1.)**1.25
22349 dgam = (qc/e0)*tspl5
22351 xpi = xpe(i)/gamm1 - xe(i)*gam(i)*dgam/(gamm2*2.)
22353 ypi = ype(i)/gamm1 - ye(i)*gam(i)*dgam/(gamm2*2.)
22357 f(3, j) = xpi*1.e03
22358 f(5, j) = ypi*1.e03
22369 if (indp==1) npas = 96
22370 if (indp==2) npas = 48
22371 if (indp==3) npas = 24
22373 xlres = egl - xlstart
22374 xpas = xlres/(float(npas)*float(ipart))
22377 dav1(idavs, 7) = tspl5
22378 dav1(idav, 5) = xlstart*1000.
22383 if (indp==1) npas = 48
22384 if (indp==2) npas = 24
22385 if (indp==3) npas = 12
22387 xlres = egl - xlstart
22388 xpas = xlres/(float(npas)*float(ipart))
22391 if (.not. flgsc)
then 22410 tref = tref + f(6, ij)
22411 gref = gref + f(7, ij)/e0
22413 tref = tref/float(ngood)
22414 gref = gref/float(ngood)
22415 bets = sqrt(1.-1./(gref*gref))
22418 write (16, 562) fpos5*1000, tref, bets, tspl5
22419 write (6, 1562) fpos5*1000, bets, cr
22420 562
format (
' ref.(c.o.g.) at ', e12.5,
' mm of the cathode', /, 5x,
' tof: ', e12.5,
' sec beta: ', e12.5, &
22421 ' field (MV/m) ', e12.5)
22422 1562
format (
' EGUN: at ', e12.5,
' mm from the cathode; beta: ', e12.5, a1, $)
22427 write (6, *)
'EGUN calculation finished' 22432 tref = tref + f(6, i)
22433 gref = gref + f(7, i)/e0
22435 tref = tref/float(ngood)
22436 gref = gref/float(ngood)
22437 bets = sqrt(1.-1./(gref*gref))
22438 write (16, 561) tref, bets
22439 561
format (
' ref. at output of the DC gun', /, 5x,
' tof: ', e12.5,
' sec beta: ', e12.5)
22442 xmor = xmat*bets*gref
22443 boro = 33.356*xmor*1.e-01/qst
22444 dav1(idavs, 6) = bets
22445 dav1(idavs, 36) = ngood
22447 call stapl(davtot*10.)
22450 end subroutine egun 22475 implicit real *8(a-h, o-z)
22476 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
22477 common /dyn/tref, vref
22479 common /part/xc(iptsz), yc(iptsz), zc(iptsz)
22480 common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
22481 common /hermt/afxt(22), afyt(22), afzt(22)
22482 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
22483 common /consta/vl, pi, xmat, rpel, qst
22484 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
22485 common /faisc/f(10, iptsz), imax, ngood
22486 common /cdek/dwp(iptsz)
22487 common /beamsa/fs(7, iptsz)
22489 common /compt/nrres, nrtre, nrbunc, nrdbun
22491 logical ichaes, iesp
22492 common /bg/bsc, gsc, phis, wsync
22495 common /fldcom/rp, zp, pl, opt, nip
22496 common /spacech1/rm(21), zm(41), rs(20), ers(16800), ezs(16800), ez(861), aa(800), rssq(20), zzs(41), er(861), &
22497 rss(20), ismax(40), iemax(41)
22498 common /rcshef/sce(20)
22501 beami = beamc/1000.0
22502 wavel = 2.*pi*vl/fh
22509 nip = idint(sce(6))
22512 if (sce(7)>0.) pl = sce(7)
22524 beami = beamc/1000.0
22525 if (beami==0. .or. scdist==0.)
return 22527 write (16, *)
' *call SCHEFF ', iell
22529 call sizrms(0, xrms, yrms, zrms, zz)
22530 write (16, 6875) xrms, yrms, zrms
22534 6875
format (
' RMS size(m)', e12.5, 2x, e12.5, 2x, e12.5)
22535 rrms = sqrt(xrms*xrms+yrms*yrms)
22539 dr = rrms*frrms/float(nr)
22540 dz = zrms1*fzrms/float(nz)
22541 rmax = float(nr)*dr
22545 rm(i) = float(i-1)*dr
22546 rssq(i-1) = .5*(rm(i-1)**2+rm(i)**2)
22547 rss(i-1) = 0.5*(rm(i-1)+rm(i))
22548 rs(i-1) = sqrt(rssq(i-1))
22552 zm(i) = float(i-1)*dz
22553 zzs(i) = zm(i) + zs
22560 q = beami/(freq*float(nq))
22561 c1 = 572167.*q/xmat
22564 rfac = (rm(k+1)**2-rm(k)**2)*dz/2.
22565 if (opt==0.) rfac = 1.
22570 if (opt==0.)
call flds(rs(k), zs, er1, ez1)
22571 if (opt==0.)
go to 35
22572 call gaus(rm(k), rm(k+1), zm(1), zm(2), opt, er1, ez1)
22574 ers(l) = c1*er1/rfac
22575 ezs(l) = c1*ez1/rfac
22579 if (beamc==0. .or. scdist==0.)
return 22582 write (16, *)
' fields acting length(cm): ', dist
22594 gpai = f(7, np)/xmat
22595 brmoy = brmoy + sqrt(1.-1./(gpai*gpai))
22596 trmoy = trmoy + f(6, np)
22598 trmoy = trmoy/float(ngood)
22601 beta = brmoy/float(ngood)
22602 gsc = 1./sqrt(1.-beta*beta)
22604 c2 = beta*wavel/(2.*pi)
22606 c3 = dist/(bg*beta*gmsq)
22609 c5 = 1./(gam*(gam+1.))
22631 epsq = sqrt((xsq-xbar*xbar)/(ysq-ybar*ybar))
22633 xfac = 2./(epsq+1.)
22641 rsq = (f(2,np)-xbar)**2*epsqi + (f(4,np)-ybar)**2*epsq
22645 i = idint(r/dr+1.0)
22646 if (i>nr)
go to 120
22648 z = -c2*(zph-phimc)
22649 if (abs(z)>=hl)
go to 120
22653 jm1 = idint(zz/dz+1.)
22656 if (rsq<rss(i)) i1 = i - 1
22660 if (zz<zzs(jm1)) j1 = jm1 - 1
22666 rminsq = (r-halfdr)**2
22667 rmaxsq = (r+halfdr)**2
22669 a = (rmaxsq-rm(i)**2)/(rmaxsq-rminsq)
22671 a = (rm(i1)**2-rminsq)/(rmaxsq-rminsq)
22676 if (j1/=jm1) cc = (zz-zzs(j1))/(zzs(jm1)-zzs(j1))
22679 aa(k) = aa(k) + a*cc
22681 aa(k) = aa(k) + b*cc
22683 aa(k) = aa(k) + a*d
22685 aa(k) = aa(k) + b*d
22694 if (aa(m)<=0.00)
then 22705 iemax(1) = 1 + ismax(1)
22707 iemax(j) = 1 + max0(ismax(j-1), ismax(j))
22709 iemax(nz1) = 1 + ismax(nz)
22719 if (ism==0)
go to 220
22723 if (a1==0.)
go to 210
22726 k1 = l + (js-je)*nr1
22729 if (iem<=1)
go to 180
22733 er(n) = er(n) + a1*ers(k)
22734 ez(n) = ez(n) - a1*ezs(k)
22738 k1 = l + (je-js1)*nr1
22741 if (iem<=1)
go to 200
22745 er(n) = er(n) + a1*ers(k)
22746 ez(n) = ez(n) + a1*ezs(k)
22758 r = sqrt((f(2,np)-xbar)**2*epsqi+(f(4,np)-ybar)**2*epsq)
22760 z = -c2*(zph-phimc)
22761 if (z>=zzmax) zzmax = z
22762 if (z<zzmin) zzmin = z
22763 if (r>=rrmax) rrmax = r
22764 if (r==0.) r = .000001
22765 xor = (f(2,np)-xbar)*xfac/r
22766 yor = (f(4,np)-ybar)*yfac/r
22775 if (abs(z)>hl)
then 22782 a = rb - float(i-1)
22786 c = zb - float(j-1)
22790 crp = c3*(d*(a*er(l+1)+b*er(l))+c*(a*er(m+1)+b*er(m)))
22791 cen = c4*(d*(a*ez(l+1)+b*ez(l))+c*(a*ez(m+1)+b*ez(m)))
22792 crp = crp*abs(f(9,np))
22793 cen = cen*abs(f(9,np))
22797 d = sqrt(z**2+r**2)
22800 if (nip==0)
go to 250
22806 d = sqrt(s**2+r**2)
22807 rod3 = rod3 + r/d**3
22808 zod3 = zod3 + s/d**3
22814 crp = eng*c1*c3*rod3*pi/2.
22815 cen = eng*c1*c4*zod3*pi/2.
22816 crp = crp*abs(f(9,np))
22817 cen = cen*abs(f(9,np))
22821 f3 = f(3, np)*1.e-03
22822 f5 = f(5, np)*1.e-03
22823 dwc = f(7, np) - xmat
22824 dxp = crp*xor - f3*cen*c5/dwc
22825 dyp = crp*yor - f5*cen*c5/dwc
22826 if (.not. iesp)
then 22829 f(js, np) = fs(js, np)
22831 f(3, np) = f(3, np) + dxp*1000.
22832 f(5, np) = f(5, np) + dyp*1000.
22833 f(2, np) = f(2, np) - dz1*dxp*100.*xpsc
22834 f(4, np) = f(4, np) - dz1*dyp*100.*xpsc
22837 f(3, np) = f(3, np) + dxp*1000.
22838 f(5, np) = f(5, np) + dyp*1000.
22839 f(7, np) = f(7, np) + cen
22879 implicit real *8(a-h, o-z)
22880 common /consta/vl, pi, xmat, rpel, qst
22881 common /rf1ptq/tvolt, avolt, fph, mlc, nceltot
22882 common /rf2ptq/rfq1(500), rfq2(500), rfq3(500), rfq4(500), rfq6(500), rfq7(500), rfq8(500), rfq9(500)
22883 common /rf5ptq/tdvolt, rfq10(500), rfq11(500)
22884 common /rfq3ptq/itype(500), ipari(500), evens, evenr
22885 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
22886 common /dyn/tref, vref
22887 common /bonda/cbx(500), bbx(500), ablx(500), cby(500), bby(500), ably(500)
22888 common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
22889 common /spff/xspf(400), yspf(400), sf(500), pf(500), qf(500)
22890 common /rms_prfl/npt, npf
22891 dimension a(16), vptq(16)
22892 character *80 vprof, fprof
22893 logical even, evens, evenr
22896 if (abs(pib)>6.*0.)
then 22911 read (27, *) nc, ityp, (vptq(j), j=1, 9), ipar
22914 read (27,
'(A80)') vprof
22915 write (16, *)
'Read RMS from file ', vprof
22919 read (27,
'(A80)') fprof
22920 write (16, *)
'Read Fringe Field from file ', fprof
22934 if (nc==1) tdvolt = a(9)
22936 if (nc==0)
go to 60
22937 if (nc>nceltot)
go to 60
22940 if (itype(nc)==5)
then 22949 write (16, *)
'RFQ RMS from potential function' 22956 xq0 = 1./6.*xk*xk*rh0*rh0
22960 cbx(nc) = 1.5*r0*1.e-02
22961 cby(nc) = 1.5*r0*1.e-02
22978 rfq3(nc) = cl*1.e-02
22980 rfq7(nc) = r0*1.e-02
22982 rfq10(nc) = (1.+tvolt)*a(9)
22983 rfq11(nc) = (1.+avolt)*a(9)
22986 if (itype(nc)==6)
then 22989 open (67, file=vprof, status=
'unknown')
22993 read (67, *, end=777) xspl(npt+1), yspl(npt+1)
22996 777
write (16, *)
'RFQ RMS from file with ', npt,
' data points' 23024 rfq10(nc) = (1.+tvolt)*a(9)
23025 rfq11(nc) = (1.+avolt)*a(9)
23033 if (itype(nc)==0)
then 23046 a01 = 3.*(1.+5.*alpha)/(2.*r0*r0*(1.+7.*alpha))
23048 a03 = -(1.+alpha)/(2.*r0**6*(1.+7.*alpha))
23052 xk1 = 1. - a01*xa*xa - a03*(xa**6)
23053 yk2 = -1. + a01*xam*xam + a03*(xam**6)
23059 bi0 =
bint(no, za0)
23062 bim =
bint(no, zam)
23066 bi4 =
bint(no, za0)
23071 bim4 =
bint(no, zam)
23076 den1 = bim4*bi0 - bim*bi4
23077 if (abs(den1)>1.e-09) a12 = (yk2*bi0-xk1*bim)/den1
23101 rfq1(nc) = a01*1.e04
23103 ncf = (ipari(nc)/2)*2 - ipari(nc)
23107 bbx(nc) = (4.*r0-xm*xa-3.*cbx(nc))/cl
23108 ablx(nc) = xa*xm/(cl*cl) - bbx(nc)/cl - cbx(nc)/(cl*cl)
23110 bby(nc) = (4.*r0-xa-3.*cby(nc))/cl
23111 ably(nc) = xa/(cl*cl) - bby(nc)/cl - cby(nc)/(cl*cl)
23115 bbx(nc) = (4.*r0-xa-3.*cbx(nc))/cl
23116 ablx(nc) = xa/(cl*cl) - bbx(nc)/cl - cbx(nc)/(cl*cl)
23118 bby(nc) = (4.*r0-xm*xa-3.*cby(nc))/cl
23119 ably(nc) = xm*xa/(cl*cl) - bby(nc)/cl - cby(nc)/(cl*cl)
23123 cbx(nc) = cbx(nc)*1.e-02
23124 ablx(nc) = ablx(nc)*1.e02
23125 cby(nc) = cby(nc)*1.e-02
23126 ably(nc) = ably(nc)*1.e02
23129 rfq3(nc) = cl*1.e-02
23132 rfq7(nc) = r0*1.e-02
23133 rfq8(nc) = a03*1.e12
23135 rfq10(nc) = (1.+tvolt)*a(9)
23136 rfq11(nc) = (1.+avolt)*a(9)
23140 if (itype(nc)==1)
then 23153 bi0 =
bint(no, za0)
23154 bim =
bint(no, zam)
23155 bi3 =
bint(no, 3.*za0)
23156 bim3 =
bint(no, 3.*zam)
23158 t10k = xm*xm*bi0 + bim
23159 t30k = xm*xm*bi3 + bim3
23162 bir0 =
bint(no, zr0)
23163 bir3 =
bint(no, zr3)
23165 if (abs(bir3)/=6.*0.) alpk = bir0/bir3
23166 dtk = t10k + alpk*t30k/3.
23168 if (abs(dtk)/=6.*0.) a10 = (xm*xm-1.)/dtk
23172 bbx(nc) = (4.*r0-xa-3.*cbx(nc))/(2.*cl)
23173 ablx(nc) = xa/(4.*cl*cl) - bbx(nc)/(2.*cl) - cbx(nc)/(4.*cl*cl)
23175 bby(nc) = (4.*r0-xm*xa-3.*cby(nc))/(2.*cl)
23176 ably(nc) = xm*xa/(4.*cl*cl) - bby(nc)/(2.*cl) - cby(nc)/(4.*cl*cl)
23178 cbx(nc) = cbx(nc)*1.e-02
23179 ablx(nc) = ablx(nc)*1.e02
23180 cby(nc) = cby(nc)*1.e-02
23181 ably(nc) = ably(nc)*1.e02
23195 rfq3(nc) = cl*1.e-02
23197 rfq7(nc) = r0*1.e-02
23199 rfq10(nc) = (1.+tvolt)*a(9)
23200 rfq11(nc) = (1.+avolt)*a(9)
23204 if (itype(nc)==2)
then 23219 bi0 =
bint(no, za0)
23220 bim =
bint(no, zam)
23221 bi3 =
bint(no, 3.*za0)
23222 bim3 =
bint(no, 3.*zam)
23224 t10k = xm*xm*bi0 + bim
23225 t30k = xm*xm*bi3 + bim3
23228 bir0 =
bint(no, zr0)
23229 bir3 =
bint(no, 3.*zr3)
23231 if (abs(bir3)/=6.*0.) alpk = bir0/bir3
23232 dtk = t10k + alpk*t30k/3.
23234 if (abs(dtk)/=6.*0.) a10 = (xm*xm-1.)/dtk
23241 bbx(nc) = (xm*xa-r0)/cl
23244 bby(nc) = (xa-r0)/cl
23247 cbx(nc) = cbx(nc)*1.e-02
23248 cby(nc) = cby(nc)*1.e-02
23260 rfq3(nc) = cl*1.e-02
23262 rfq7(nc) = r0*1.e-02
23264 rfq10(nc) = (1.+tvolt)*a(9)
23265 rfq11(nc) = (1.+avolt)*a(9)
23268 if (itype(nc)==3)
then 23284 cbx(nc) = cbx(nc)*1.e-02
23285 cby(nc) = cby(nc)*1.e-02
23298 rfq3(nc) = cl*1.e-02
23300 rfq7(nc) = r0*1.e-02
23302 rfq10(nc) = (1.+tvolt)*a(9)
23303 rfq11(nc) = (1.+avolt)*a(9)
23308 if (itype(nc)==4)
then 23325 cbx(nc) = cbx(nc)*1.e-02
23326 cby(nc) = cby(nc)*1.e-02
23339 rfq3(nc) = cl*1.e-02
23341 rfq7(nc) = r0*1.e-02
23343 rfq10(nc) = (1.+tvolt)*a(9)
23344 rfq11(nc) = (1.+avolt)*a(9)
23348 if (itype(nc)==7)
then 23351 open (67, file=fprof, status=
'unknown')
23355 read (67, *, end=888) xspf(npf+1), yspf(npf+1)
23358 888
write (16, *)
'RFQ FF from file with ', npf,
' data points' 23361 xspf(i) = xspf(i) - reca
23368 write (16, *)
'Fringe Field length=', cl,
' m' 23369 write (16, *)
'Fringe Field Phase=', phim
23370 write (16, *)
'Fringe Field Field Factor=',
fact 23392 rfq10(nc) = (1.+tvolt)*a(9)
23393 rfq11(nc) = (1.+avolt)*a(9)
23400 if (netc<nceltot)
then 23401 write (6, *)
'Error: Parameter NCELTOT after RFQPTQ entry in',
' DYNAC input file is ', nceltot
23402 write (6, *)
'This is larger than the',
' number of cells in the RFQ datafile, which is ', netc
23403 write (16, *)
'Error: Parameter NCELTOT after RFQPTQ entry in',
' DYNAC input file is ', nceltot
23404 write (16, *)
'This is larger than the',
' number of cells in the RFQ datafile, which is ', netc
23415 function bint(n, z)
23416 implicit real *8(a-h, o-z)
23417 common /consta/vl, pi, xmat, rpel, qst
23418 dimension ui(16), wi(16)
23420 data (ui(j), j=1, 16)/ -.9894009, -.9445750, -.8656312, -.7554044, -.6178762, -.4580168, -.2816036, -.0950125, &
23421 .0950125, .2816036, .4580168, .6178762, .7554044, .8656312, .9445750, .9894009/
23422 data (wi(j), j=1, 16)/.0271524, .0622535, .0951585, .1246288, .1495960, .1691565, .1826034, .1894506, .1894506, &
23423 .1826034, .1691565, .1495960, .1246288, .0951585, .0622535, .0271524/
23427 thet = pi/2.*(1.+ui(i))
23430 fonc = exp(cthet*z)*cos(fln*thet)
23442 implicit real *8(a-h, o-z)
23443 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
23444 common /consta/vl, pi, xmat, rpel, qst
23445 common /faisc/f(10, iptsz), imax, ngood
23446 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
23447 common /sc3/beamc, scdist, sce10, cplm, ectt, apl, ichaes, iscsp
23448 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
23449 common /dyn/tref, vref
23450 common /mcs/imcs, ncstat, cstat(20)
23451 common /tapes/in, ifile, meta
23452 common /etcha3/ichxyz(iptsz)
23454 common /etcom/cog(8), exten(17), fd(iptsz)
23459 drad = (f(6,i)-tref)*fh
23462 f(6, i) = (f(6,i)-2.*pi/fh)
23464 if (drad<-pib)
then 23466 f(6, i) = (f(6,i)+2.*pi/fh)
23473 tcog = tcog + f(6, i)
23475 tcog = tcog/float(ngood)
23477 write (16, 59) tcog*fh*180./pi
23478 59
format (
' Phase of COG after reinjecting particles into the ',
'bunch: ', e13.7,
' deg')
23563 implicit real *8(a-h, o-z)
23564 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
23566 common /consta/vl, pi, xmat, rpel, qst
23567 common /dyn/tref, vref
23568 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
23569 common /faisc/f(10, iptsz), imax, ngood
23570 common /tapes/in, ifile, meta
23571 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
23572 common /etcom/cog(8), exten(17), fd(iptsz)
23573 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
23574 common /fene/wdisp, wphas, wx, wy, rlim, ifw
23576 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
23577 common /compt/nrres, nrtre, nrbunc, nrdbun
23578 common /shif/dtiph, shift
23579 common /femt/iemgrw, iemqesg
23581 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
23583 common /azlist/icont, iprin
23584 common /trfq/icour, ncell
23585 logical iesp, ichaes, shift, iemgrw, iflag
23586 common /itvole/itvol, imamin
23587 common /tofev/ttvols
23588 common /rf1ptq/tvolt, avolt, fph, mlc, nceltot
23589 common /rf2ptq/rfq1(500), rfq2(500), rfq3(500), rfq4(500), rfq6(500), rfq7(500), rfq8(500), rfq9(500)
23590 common /rf5ptq/tdvolt, rfq10(500), rfq11(500)
23592 common /rfq3ptq/itype(500), ipari(500), evens, evenr
23593 common /bonda/cbx(500), bbx(500), ablx(500), cby(500), bby(500), ably(500)
23594 logical itvol, imamin
23595 common /conti/irfqp
23596 common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
23597 common /spff/xspf(400), yspf(400), sf(500), pf(500), qf(500)
23598 common /rms_prfl/npt, npf
23601 common /fcont/ifcont
23605 logical irfqp, evens, evenr
23606 dimension rfqdmp(500, 10)
23617 wavel = 2.*pi*vlm/fh
23620 if (iprf==1)
call stapl(davtot*10.)
23625 dav1(idav, 9) = tdvolt*1000.
23626 dav1(idav, 7) = float(nceltot)
23627 dav1(idav, 8) = tdvolt*1000.
23633 do ncell = 1, nceltot
23634 write (6, 8254) nrtre, ncell, cr
23635 8254
format (
'Transport element:', i5,
' RFQ cell :', i5,
' ', a1, $)
23637 if (itype(ncell)==5) ns = 126
23638 if (itype(ncell)==6) ns = 126
23642 davtot = davtot + cl*100.
23643 xlrfq = xlrfq + cl*100.
23644 if (itype(ncell)==0)
then 23647 rtvolt = rfq10(ncell)
23648 vorsq = rfq1(ncell)*rtvolt
23649 av = rfq2(ncell)*rtvolt
23650 a12v = rfq6(ncell)*rtvolt
23652 pavolt = rfq11(ncell)
23653 vorb = rfq1(ncell)*pavolt*rfq9(ncell)
23654 avb = rfq2(ncell)*pavolt*rfq9(ncell)
23655 a12vb = rfq6(ncell)*pavolt*rfq9(ncell)
23656 a03vb = rfq8(ncell)*pavolt*rfq9(ncell)
23658 if (itype(ncell)==1)
then 23661 rtvolt = rfq10(ncell)
23662 a31v = rfq1(ncell)*rtvolt
23663 a10v = rfq2(ncell)*rtvolt
23665 pavolt = rfq11(ncell)
23666 a31vb = rfq1(ncell)*pavolt*rfq9(ncell)
23667 av10b = rfq2(ncell)*pavolt*rfq9(ncell)
23669 if (itype(ncell)==2)
then 23672 rtvolt = rfq10(ncell)
23673 a31v = rfq1(ncell)*rtvolt
23674 a10v = rfq2(ncell)*rtvolt
23676 pavolt = rfq11(ncell)
23677 a31vb = rfq1(ncell)*pavolt*rfq9(ncell)
23678 a10vb = rfq2(ncell)*pavolt*rfq9(ncell)
23680 if (itype(ncell)==4)
then 23683 rtvolt = rfq10(ncell)
23684 av = rfq2(ncell)*rtvolt
23686 pavolt = rfq11(ncell)
23687 avb = rfq2(ncell)*pavolt*rfq9(ncell)
23691 if (itype(ncell)==7)
then 23694 rtvolt = rfq10(ncell)
23696 pavolt = rfq11(ncell)
23697 a31vb = pavolt*rfq9(ncell)
23701 if (itype(ncell)==5)
then 23703 rtvolt = rfq10(ncell)
23704 a31v = rfq1(ncell)*rtvolt
23705 a10v = rfq2(ncell)*rtvolt
23707 pavolt = rfq11(ncell)
23708 a31vb = rfq1(ncell)*pavolt*rfq9(ncell)
23709 av10b = rfq2(ncell)*pavolt*rfq9(ncell)
23712 if (itype(ncell)==6)
then 23714 rtvolt = rfq10(ncell)
23716 pavolt = rfq11(ncell)
23717 a31vb = pavolt*rfq9(ncell)
23723 tcog = tcog + f(6, i)
23724 ecog = ecog + f(7, i)
23726 tcog = tcog/float(ngood)
23727 ecog = ecog/float(ngood)
23729 bcog = sqrt(1.-1./(gcog*gcog))
23733 if (.not. shift)
then 23743 gref = 1./sqrt(1.-bref*bref)
23744 wref = er*(gref-1.)
23749 if (itype(ncell)==0) cay = pi/cl
23751 if (itype(ncell)==1) cay = pi/(2.*cl)
23752 if (itype(ncell)==2) cay = pi/(2.*cl)
23753 if (itype(ncell)==5) cay = pi/(2.*cl)
23754 if (itype(ncell)==6) cay = pi/(2.*cl)
23756 if (itype(ncell)==4)
then 23758 ns = int(36.*cl/(bref*wavel))
23764 if (itype(ncell)==7)
then 23766 ns = int(36.*cl/(bref*wavel))
23779 phini = -tref*fh + rfq4(ncell)*radian
23782 178
format (/,
' Dynamics at the input', /, 5x,
' BETA GAMMA ENERGY(MeV) ', &
23783 ' TOF(deg) TOF(sec)')
23784 write (16, 1788) bcog, gcog, wcog, tcog*fh*180./pi, tcog
23785 1788
format (
' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
23786 write (16, 165) bref, gref, wref, tref*fh*180./pi, tref
23787 165
format (
' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
23790 9627
format (5x,
'ncell', 4x,
'A01(m-2)', 8x,
'A10', 12x,
'A12', 11x,
'r0(m)', 11x,
'A03(m-6)')
23792 9977
format (5x,
'ncell', 4x,
'Zcell(m)', 7x,
'Z(m)', 9x,
'Phi(deg)', 8x,
'Pho(deg)', 7x,
'Wsyn', 11x,
'Wcog', 9x, &
23795 9888
format (4x,
'ncell', 1x,
'z(m) middle', 4x,
'phini(deg)', 5x,
'phmid(deg)')
23805 phfin = tref*fh + phini
23806 phfin = phfin*180./pi
23809 rfqdmp(ncell, 1) = zl
23811 rfqdmp(ncell, 1) = zl + rfqdmp(ncell-1, 1)
23813 rfqdmp(ncell, 2) = phdep
23814 write (70, 9999) ncell, zl, tlgth, phdep, phfin, wref, wcog, ngood
23815 9999
format (2x, i5, 6(3x,e12.5), 3x, i6)
23819 tref = tref + hl/(bref*vlm)
23820 if (itvol) ttvols = tref
23821 phref = tref*fh + phini
23828 if (itype(ncell)==0)
then 23829 dwref = .5*qst*cay*av*skz*sp*xl
23831 if (n==1) phdep = rfq4(ncell)
23834 if (itype(ncell)==1)
then 23835 skz3 = sin(3.*cay*z)
23836 ckz3 = cos(3.*cay*z)
23837 dwref = 0.5*qst*cay*(a10v*skz+3.*a31v*skz3)*sp*xl
23839 if (n==1) phdep = rfq4(ncell)
23842 if (itype(ncell)==2)
then 23843 skz3 = sin(3.*cay*z)
23844 ckz3 = cos(3.*cay*z)
23845 dwref = 0.5*qst*cay*(a10v*ckz+3.*a31v*ckz3)*sp*xl
23847 if (n==1) phdep = rfq4(ncell)
23850 if (itype(ncell)==3)
then 23853 if (n==1) phdep = rfq4(ncell)
23856 if (itype(ncell)==4)
then 23857 rtvolt = rfq10(ncell)
23858 av = rfq2(ncell)*rtvolt
23859 c3kz = cos(3.*cay*z)
23860 skpz = .75*(skz+sin(3.*cay*z))
23861 dwref = .5*qst*cay*av*skpz*sp*xl
23863 if (n==1) phdep = rfq4(ncell)
23867 if (itype(ncell)==7)
then 23870 c3kz = cos(3.*cay*z)
23874 if (n==1) phdep = rfq4(ncell)
23878 if (itype(ncell)==5)
then 23881 if (n==1) phdep = rfq4(ncell)
23884 if (itype(ncell)==6)
then 23891 if (n==1) phdep = rfq4(ncell)
23894 wrefm = wref + 0.5*
dwref 23895 grefm = wrefm/er + 1.
23896 brefm = sqrt(1.-1./(grefm*grefm))
23897 wref = wref +
dwref 23898 gref = wref/er + 1.
23899 bref = sqrt(1.-1./(gref*gref))
23905 xi = f(2, ip)*1.e-02
23906 xpi = f(3, ip)*1.e-03
23907 yi = f(4, ip)*1.e-02
23908 ypi = f(5, ip)*1.e-03
23914 write (49, 5558) ip, ncell, ww
23918 5558
format (
' particle: ', i5,
' cell: ', i5,
' energy: ', e12.5)
23924 write (49, *)
' particle lost: ', i,
' W: ', ww,
' MeV' 23928 bi = sqrt(1.-1./(gi*gi))
23931 tim = f(6, ip) + hl/(bi*vlm)
23932 phi = fh*(tim-tref)
23934 f(6, ip) = f(6, ip) - 2.*pi/fh
23935 tim = f(6, ip) + hl/(bi*vlm)
23936 phi = fh*(tim-tref)
23937 if (abs(phi)>pi)
then 23940 write (49, 5559) ip, ncell, phi, f(9, ip)
23946 f(6, ip) = f(6, ip) + 2.*pi/fh
23947 tim = f(6, ip) + hl/(bi*vlm)
23948 phi = fh*(tim-tref)
23949 if (abs(phi)>pi)
then 23952 write (49, 5559) ip, ncell, phi, f(9, ip)
23957 5559
format (
' particle: ', i5,
' cell: ', i5,
' phi(rad): ', e12.5,
' charge state ', f6.2)
23958 tim = f(6, ip) + hl/(bi*vlm)
23959 phi = phini + fh*tim
23972 rm = sqrt(xm*xm+ym*ym)
23975 vanx = ablx(ncell)*z*z + bbx(ncell)*z + cbx(ncell)
23976 vany = ably(ncell)*z*z + bby(ncell)*z + cby(ncell)
23979 if (abs(xm)>=vanx) f(8, ip) = 0.
23980 if (abs(ym)>=vany) f(8, ip) = 0.
23981 if (f(8,ip)==0.)
then 23983 write (49, 5556) ip, ncell, abs(xm), vanx, abs(ym), vany, rm
23984 5556
format (
' particle: ', i5,
' cell: ', i5,
' abs(x) (m): ', e12.5,
' x-v(m): ', e12.5,
' abs(y) (m):', &
23985 e12.5,
' y-v(m): ', e12.5,
' radius (m) ', e12.5)
23994 write (49, 5557) ip, ncell, rm, r0
23995 5557
format (
' particle: ', i5,
' cell: ', i5,
' radius (ptcl) (m): ', e12.5,
' radius (cell) (m):', e12.5)
24005 if (abs(xm)>1.e-10)
then 24006 theta = atan(ym/xm)
24010 if (xm<0.) signx = -1.
24011 if (ym<0.) signy = -1.
24014 if (xm<0.) signx = -1.
24015 if (ym>0.) signy = -1.
24018 if (abs(xm)<=1.e-10)
then 24019 if (abs(ym)>1.e-10)
then 24020 if (xm>=0. .and. ym>0.) theta = pi/2
24021 if (xm>=0. .and. ym<0.) theta = -pi/2
24022 if (xm<0. .and. ym<0.) theta = pi/2
24023 if (xm<0. .and. ym>0.) theta = -pi/2
24026 if (theta==0.)
then 24031 if (itype(ncell)==0)
then 24034 bi0 = 1. + zrm*zrm/4. + zrm**4/64.
24038 bi1 = zrm/2. + zrm**3/16.
24040 if (rm/=6.*0.) bi1p = bi1/rm
24041 bi3 = zrm**3/48. + zrm**5/768
24044 if (rm>1.e-06) bi4r = bi4/rm
24046 c2t = cos(2.*theta)
24047 s2t = sin(2.*theta)
24051 erf = vorb*c2t*2.*rm + cay*(avb*bi1+a12vb*(bi3+bi5)*cos(4.*theta)/2.)*ckz
24053 etf = vorb*s2t*2.*rm + 4.*a12vb*bi4r*sin(4.*theta)*ckz
24057 ncf = (ipari(ncell)/2)*2 - ipari(ncell)
24064 ex = erf*c1t - etf*s1t
24065 ey = erf*s1t + etf*c1t
24070 if (itype(ncell)==1)
then 24074 bi0 = 1. + zrm*zrm/4. + zrm**4/64. + zrm**6/2304.
24076 bi03 = 1. + zrm3*zrm3/4. + zrm3**4/64. + zrm3**6/2304.
24078 bi1 = zrm/2. + zrm**3/16. + zrm**5/384.
24081 bi13 = zrm3/2. + zrm3**3/16. + zrm3**5/384.
24084 c2t = cos(2.*theta)
24085 s2t = sin(2.*theta)
24088 pavolt = rfq11(ncell)
24089 rpv = pavolt*rfq9(ncell)
24090 ncf = (ipari(ncell)/2)*2 - ipari(ncell)
24093 erf = -rpv/(r0*r0)*c2t*rm
24094 erf = erf + cay/2.*(av10b*bi1*ckz+3.*a31vb*bi13*ckz3)
24095 etf = rpv/(r0*r0)*s2t*rm
24097 erf = -rpv/(r0*r0)*c2t*rm
24098 erf = erf - cay/2.*(av10b*bi1*ckz+3.*a31vb*bi13*ckz3)
24099 etf = rpv/(r0*r0)*s2t*rm
24101 ex = erf*c1t - etf*s1t
24102 ey = erf*s1t + etf*c1t
24108 if (itype(ncell)==2)
then 24112 bi0 = 1. + zrm*zrm/4. + zrm**4/64. + zrm**6/2304.
24114 bi03 = 1. + zrm3*zrm3/4. + zrm3**4/64. + zrm3**6/2304.
24116 bi1 = zrm/2. + zrm**3/16. + zrm**5/384.
24119 bi13 = zrm3/2. + zrm3**3/16. + zrm3**5/384.
24122 c2t = cos(2.*theta)
24123 s2t = sin(2.*theta)
24126 pavolt = rfq11(ncell)
24127 rpv = pavolt*rfq9(ncell)
24128 erf = -rpv/(r0*r0)*c2t*rm
24131 erf = erf + 0.5*cay*(a10vb*bi1*skz+3.*a31vb*bi13*skz3)
24133 etf = rpv/(r0*r0)*s2t*rm
24136 ncf = (ipari(ncell)/2)*2 - ipari(ncell)
24141 ex = erf*c1t - etf*s1t
24142 ey = erf*s1t + etf*c1t
24147 if (itype(ncell)==3)
then 24148 c2t = cos(2.*theta)
24149 s2t = sin(2.*theta)
24152 pavolt = rfq11(ncell)
24153 rpv = pavolt*rfq9(ncell)
24154 erf = -rpv/(r0*r0)*c2t*rm
24155 etf = rpv/(r0*r0)*s2t*rm
24172 ncf = (ipari(ncell)/2)*2 - ipari(ncell)
24177 ex = erf*c1t - etf*s1t
24178 ey = erf*s1t + etf*c1t
24183 if (itype(ncell)==5)
then 24184 c2t = cos(2.*theta)
24185 s2t = sin(2.*theta)
24188 skz3 = sin(3.*cay*z)
24189 ckz3 = cos(3.*cay*z)
24192 b2kr3 = (9./8.)*zrm*zrm
24197 qzrm = (b2kr*skz-(1./27.)*b2kr3*skz3)
24198 erf = -1./8.*a31vb*cay*cay*(skz-1/3.*skz3)*c2t
24200 etf = a31vb*qzrm*s2t/rm
24202 ex = erf*c1t - etf*s1t
24203 ey = erf*s1t + etf*c1t
24208 if (itype(ncell)==6)
then 24210 cc = a31vb*qq*xl*sp/(bgfac*er)
24211 rr1 = -cc/(rprof*rprof)
24212 rr2 = cc/(rprof*rprof)
24218 if (itype(ncell)==7)
then 24220 c1 = .75*(ckz+c3kz/3.)
24221 cc = a31vb*qq*xl*sp/(bgfac*er)
24222 rr1 = -cc/(rproff*rproff)
24223 rr2 = cc/(rproff*rproff)
24225 ncf = (ipari(ncell)/2)*2 - ipari(ncell)
24238 if (itype(ncell)==0)
then 24239 ez = 0.5*(avb*bi0+a12vb*bi4*cos(4.*theta))*skz*cay
24245 if (itype(ncell)==1)
then 24246 ez = 0.5*cay*(av10b*skz*bi0+3.*a31vb*skz3*bi03)
24250 if (itype(ncell)==2)
then 24251 ez = 0.5*cay*(a10vb*ckz*bi0+3.*a31vb*ckz3*bi03)
24255 if (itype(ncell)==3) dw = 0.
24258 if (itype(ncell)==4) dw = .5*qq*cay*avb*skz*sp*xl
24259 if (itype(ncell)==7) dw = 0.
24262 if (itype(ncell)==5)
then 24263 ez = -1./16.*a31vb*cay**3*rm*rm*(ckz-ckz3)*c2t
24267 if (itype(ncell)==6)
then 24277 write (49, *)
' particle lost: ', i,
' W: ', wav,
' MeV' 24281 bgav = sqrt(ga*(2.+ga))
24292 write (49, *)
' particle lost: ', i,
' W: ', ww,
' MeV' 24296 bg = sqrt(ga*(2.+ga))
24297 beta = sqrt(1.-1/(gam*gam))
24306 cc = qq*xl*sp/(bgfac*er)
24308 if (itype(ncell)/=4)
then 24309 if (itype(ncell)==6)
go to 9766
24310 if (itype(ncell)==7)
go to 9766
24314 xpm = xpi*amort + rr1
24315 ypm = ypi*amort + rr2
24321 if (itype(ncell)==4)
then 24337 pavolt = rfq11(ncell)
24339 rpv = pavolt*rfq9(ncell)
24340 rf1 = qq*rpv/(r0*r0*er)
24342 rf2 = .25*qq*cay*cay*avb/er
24344 ncf = (ipari(ncell)/2)*2 - ipari(ncell)
24349 c1 = rf1*sp*xl/bgfac
24350 c2 = rf2*ckz*sp*xl/bgfac
24351 c1 = c1*.75*(ckz+c3kz/3.)
24352 c2 = c2*.75*(ckz+3.*c3kz)
24355 xpm = xpi*amort + rr1*xm
24356 ypm = ypi*amort + rr2*ym
24363 f(3, ip) = xpm*1000.
24364 f(5, ip) = ypm*1000.
24367 f(6, ip) = f(6, ip) + hl/(bi*vlm)
24369 f(6, ip) = f(6, ip) + hl/(bi*vlm) + hl/(beta*vlm)
24390 tref = tref + hl/(bref*vlm)
24391 if (itvol) ttvols = tref
24396 phmil = tref*fh + phini
24397 phmil = phmil*180./pi
24398 write (89, 9735) ncell, z, phdep, phmil
24399 9735
format (2x, i5, 3(2x,e12.5))
24410 tcog = tcog + f(6, i)
24411 ecog = ecog + f(7, i)
24413 tcog = tcog/float(ngood)
24414 ecog = ecog/float(ngood)
24416 bcog = sqrt(1.-1./(gcog*gcog))
24422 if (ifw==0 .or. ifw==10)
then 24423 dispr = gcog*gcog*wdisp/(gcog*(gcog+1.))
24425 if (ifw==1 .or. ifw==11)
then 24426 dispr = gcog*gcog*wdisp/(gcog*(gcog+1.)*wcog)
24430 dese = abs(fd(i)-1.)
24431 if (dese>dispr)
then 24434 write (49, *)
' particle lost: ', i,
' dp/p: ', dese,
' window :', dispr
24444 tcog = tcog + f(6, i)
24445 ecog = ecog + f(7, i)
24447 tcog = tcog/float(ngood)
24448 ecog = ecog/float(ngood)
24450 bcog = sqrt(1.-1./(gcog*gcog))
24453 br0 = rfq7(ncell)*rfq7(ncell)
24454 bff = (1./er)*wavel*wavel*tdvolt/br0
24455 write (75, 5555) ncell, rfq1(ncell), rfq2(ncell), rfq6(ncell), rfq7(ncell), rfq8(ncell)
24456 5555
format (3x, i5, 5(3x,e12.5))
24460 trfprt = fh*tref*180./pi
24461 tcgprt = fh*tcog*180./pi
24470 trnsms = 100.*float(ngood)/float(imax)
24474 bcog = sqrt(1.-1./(gcog*gcog))
24477 surxth = sqrt(exten(4)*exten(5)-exten(8)**2)
24478 suryph = sqrt(exten(6)*exten(7)-exten(9)**2)
24479 sqmdv = sqrt(exten(1)*exten(3)-exten(2)*exten(2))
24480 exns = bcog*surxth*10./sqrt(1.-bcog*bcog)
24481 eyns = bcog*suryph*10./sqrt(1.-bcog*bcog)
24482 emns = sqmdv*1.e12/fh
24484 write (50, *)
'# rfqparm.dmp' 24485 write (50, *)
'# cell Z trans ',
'PHIs TOF(COG) COG Wcog TOF(REF) ', &
24486 ' REF Wref Ex,RMS,n Ey,RMS,n El,RMS' 24487 write (50, *)
'# # (m) (%) ',
'(deg) (deg) beta (MeV) (deg) ', &
24488 ' beta (MeV) (mm.mrad) (mm.mrad) (ns.keV)' 24490 write (50, 7023) ncell, rfqdmp(ncell, 1), trnsms, rfqdmp(ncell, 2), tcgprt, bcog, wcog, trfprt, bref, wref, &
24492 7023
format (1x, i4, 1x, e12.5, 1x, f6.2, 1x, f7.2, 1x, 2(e14.7,1x,f7.5,1x,e14.7,1x), 3(e12.5,1x))
24493 if (ncell==nceltot)
then 24495 179
format (/,
' Dynamics at the output', /, 5x,
' BETA GAMMA ENERGY(MeV) ', &
24496 ' TOF(deg) TOF(sec)')
24497 write (16, 1788) bcog, gcog, wcog, tcog*fh*180./pi, tcog
24498 write (16, 165) bref, gref, wref, tref*fh*180./pi, tref
24499 if (itvol)
write (16, *)
' time of flight: ', ttvols*fh*180./pi,
' deg' 24501 xmor = xmat*bref*gref
24502 boro = 33.356*xmor*1.e-01/qst
24503 dav1(idav, 4) = davtot*10.
24504 dav1(idav, 5) = xlrfq*10.
24505 dav1(idav, 6) = (gref-1.)*er
24506 dav1(idav, 36) = ngood
24510 call stapl(davtot*10.)
24516 write (16, *)
'After RFQ, bunched beam assumed' 24524 implicit real *8(a-h, o-z)
24525 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
24526 common /spl/x(4000), y(4000), s(5000), p(5000), q(5000)
24527 common /strip/atm, qs, atms, ths, qop, sqst(6), anp, nqst
24528 common /mcs/imcs, ncstat, cstat(20)
24529 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
24530 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
24531 common /consta/vl, pi, xmat, rpel, qst
24532 common /qmoyen/qmoy
24534 common /faisc/f(10, iptsz), imax, ngood
24535 dimension pc(20), npcent(20)
24536 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
24539 dimension xeast(21), yeast(21), vecx(1)
24543 data xeast/0.0, 2.0, 4.0, 6.0, 8.0, 10.0, 12.0, 14.0, 16.0, 18.0, 20.0, 22.0, 24.0, 26.0, 28.0, 30.0, 32.0, 34.0, &
24545 data yeast/0.00, 0.60, 1.04, 1.56, 1.80, 2.08, 2.32, 2.72, 2.96, 3.20, 3.44, 3.624, 3.808, 3.992, 4.176, 4.360, &
24546 4.544, 4.728, 4.912, 5.096, 5.28/
24555 write (6, 8254) nrtre, nstrp, cr
24556 8254
format (
'Transport element:', i5,
' Charge Stripper :', i5, a1, $)
24557 write (16, 101) anp, atm
24558 101
format (
'***** Projectile ', /, 4x,
'atomic number: ', f4.0,
' atomic mass : ', f4.0)
24559 write (16, 100) qs, atms, ths
24560 100
format (
'***** Charge Stripper ', /, 4x,
'atomic number: ', f4.0,
' atomic mass : ', f4.0,
' thickness: ', e12.5, &
24568 if (iprf==1)
call stapl(davtot*10.)
24573 dav1(idav, 2) = atms
24574 dav1(idav, 3) = ths
24575 dav1(idav, 4) = davtot*10.
24579 wicg = f(7, i) + wicg
24581 wicg = wicg/float(ngood)
24583 bcog = sqrt(gcog*gcog-1.)/gcog
24595 wp = f(7, ip) - xmat
24600 qsp = qs**(2./3) + qp**(2./3)
24601 xa = 4.68165e-9/sqrt(qsp)
24604 thck = xn*pi*xa*xa*ths
24608 rthet =
spline(np, thck)
24610 rthet = 9.2e-02*thck + 1.6
24613 zps = qs*qp/(xa*wp)
24614 dthet = 2.88e-10*zps*rthet
24625 call randga(len, sm, ax, vx)
24628 call randga(len, sm, ay, vy)
24631 aps = (atms+atm)/(atms*atm)
24632 xb = 1.44e-13*aps*qs*qp/sqrt(wpatm)
24634 alpha = 1.576e-02*qp*qs/sqrt(wpatm)
24635 write (16, 5830) xa, thck, rthet, xb, dthet, alpha
24636 5830
format (4x,
'screening distance: ', e12.5,
' cm', /, 4x,
'reduced thickness: ', e12.5, &
24637 ' reduced half angle: ', e12.5,
' rad ', /, 4x,
'closest distance of approach: ', e12.5,
' cm', /, 4x, &
24638 'half angle of diffusion: ', e12.5,
' mrad', /, 4x,
'Bohr parameter: ', e12.5)
24641 wapc = 4.*atm*atms/((atm+atms)**2)
24642 dene = wapc*xb*xb*rthet*rthet/(xa*xa)*wp
24643 denes = denes + dene
24644 f(7, ip) = f(7, ip) - dene
24648 denes = denes/float(ngood)
24649 write (16, *)
'dE(MeV) (Eastham): ', dene, denes
24650 if (qs==6. .or. qs==3.)
then 24654 fksi = 0.1535375*(qs/atms)*anp*ths/(bcog*bcog)
24655 des = 0.5*0.001*(1.866+1.57*log(wicg/atm))*(anp/atm)
24656 des = des*sqrt(1000000.*ths*qs/atms)
24657 write (16, *)
'dE(MeV) stripping: ', des, des*atm, wicg, wicg/atm
24658 write (16, *)
'dE(MeV) ksi: ', fksi
24660 qbar = anp*(1.-exp(-83.275*bcog/(anp**0.447)))
24661 qavg = qbar*(1.-exp(-12.905+0.2124*anp-0.00122*anp*anp))
24663 stdv = sqrt(qbar*(0.07535+0.19*yy-0.2654*yy*yy))
24664 con = 1./(stdv*sqrt(2.*pi))
24665 fact = -1./(2.*stdv*stdv)
24670 thresh = 100./float(ngood)
24671 write (16, 7830) thresh
24672 7830
format (4x,
'Carbon foil stripper. Charge state distribution', &
24673 ' based on E.Baron et al, NIM A328 (1993) p.177-182', /, 4x,
'Threshhold for cutoff of the distribution: ', &
24677 pcent = 100.*con*exp(
fact*(float(i)-qavg)*(float(i)-qavg))
24678 if (pcent>thresh)
then 24679 numchs = numchs + 1
24680 sqst(numchs) = float(i)
24682 pcsum = pcsum + pcent
24686 f(9, 1) = float(int(qavg))
24688 write (16, 111) nqst, int(qavg)
24690 111
format (4x,
'Number of charge states after the foil ', i2, /, 4x,
'Average charge state: ', i3)
24694 npcent(i) = int(pc(i)*float(ngood)/100.)
24695 ntot = ntot + npcent(i)
24699 write (16, 122) sqst(i), npcent(i), pc(i)
24703 write (16, *)
' ntot,ngood=', ntot, ngood,
' particles' 24705 if (int(sqst(i))==int(f(9,1)))
then 24706 npcent(i) = npcent(i) + ngood - ntot
24708 cstat(i) = float(int(sqst(i)))
24709 charm(i) = cstat(i)
24710 write (16, 122) sqst(i), npcent(i), pc(i)
24712 122
format (4x,
'Charge=', f3.0,
' with ', i5,
' particles',
' or ', f12.7,
' %')
24718 call rlux(vecx, len)
24720 ncount = int(xarpha*(float(numchs)+0.5))
24723 if (npcent(ncount)>0)
then 24724 npcent(ncount) = npcent(ncount) - 1
24725 f(9, i) = float(int(sqst(ncount)))
24738 wcg = f(7, i) + wcg
24739 qcg = f(9, i) + qcg
24741 wcg = wcg/float(ngood)
24743 qcg = qcg/float(ngood)
24745 bref = sqrt(gcg*gcg-1.)/gcg
24748 xmor = xmat*bref*gcg
24749 boro = 33.356*xmor*1.e-01/qcg
24750 diff = (wcg-xmat) - wicg
24751 dav1(idav, 5) = qavg
24752 dav1(idav, 6) = diff
24753 dav1(idav, 36) = ngood
24754 write (16, 5420) wicg, -diff
24755 5420
format (4x,
'energy of cog: at entrance: ', e12.5,
' MeV', /, 4x,
'energy loss of cog: ', e12.5,
' MeV')
24757 call stapl(davtot*10.)
24761 subroutine randga(len, s, am, v)
24766 implicit real *8(a-h, o-z)
24771 call rlux(vecx, len)
24786 subroutine qelec(volt, xlqua, rs)
24787 implicit real *8(a-h, o-z)
24788 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
24789 common /fene/wdisp, wphas, wx, wy, rlim, ifw
24790 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
24791 common /dyn/tref, vref
24792 common /consta/vl, pi, xmat, rpel, qst
24794 common /faisc/f(10, iptsz), imax, ngood
24795 common /etcom/cog(8), exten(17), fd(iptsz)
24796 common /qmoyen/qmoy
24799 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
24801 common /tapes/in, ifile, meta
24802 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
24803 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
24804 common /shif/dtiph, shift
24806 common /compt/nrres, nrtre, nrbunc, nrdbun
24807 common /rander/ialin
24809 common /qskew/qtwist, iqrand, itwist, iaqu
24811 common /femt/iemgrw, iemqesg
24813 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
24814 common /qsex/l, kq2, ks2
24815 common /tofev/ttvols
24816 common /itvole/itvol, imamin
24817 logical itvol, imamin
24818 real *8 l, kq2, ks2
24824 if (iprf==1)
call stapl(davtot*10.)
24825 write (16, *)
' ***QUADRUPOLE (electrostatic)***' 24828 if (itvol)
write (16, 10) ttvols*fcpi, davtot
24829 10
format (
' ** tof for adjustments at input: ', e12.5,
' deg at position: ', e12.5,
' cm in lattice')
24833 write (6, 8254) nrtre, nrres, cr
24834 8254
format (
'Transport element:', i5,
' Accelerating element:', i5, a1, $)
24839 if (abs(volt)>1.e-13)
then 24841 if (iqrand==0)
then 24847 call rlux(trans, len)
24848 if (trans(1)<=rdcf) sign = -1.
24849 if (trans(1)>rdcf) sign = 1.
24850 call rlux(trans, len)
24851 qtwrad = qtwist*sign*trans(1)
24861 dav1(idav, 1) = xlqua*10.
24862 davtot = davtot + xlqua
24863 dav1(idav, 4) = davtot*10.
24867 gpa = gpa + f(7, ii)/xmat
24869 gpa = gpa/float(ngood)
24870 bet = sqrt(gpa*gpa-1.)/gpa
24875 rigid = eni*bet*bet/qi*1.e03
24877 xgrad = 2.*volt/rs**2
24878 dav1(idav, 2) = volt
24879 dav1(idav, 3) = rigid
24880 dav1(idav, 5) = xgrad
24883 dav1(idav, 6) = kq2
24884 dav1(idav, 7) = rs*10.
24885 write (16, 100) xlqua, rs, volt, kq2, xgrad, rigid
24886 100
format (
' LENGTH = ', e12.5,
' cm APERTURE RADIUS= ', e12.5,
' cm', /,
' VOLTAGE = ', e12.5,
' kV K2 = ', &
24887 e12.5,
' cm-2 GRADIENT = ', e12.5,
' kV/cm2', /,
' RIGIDITY = ', e12.5,
' kV', /)
24896 gpa = f(7, ii)/xmat
24897 bet = sqrt(gpa*gpa-1.)/gpa
24900 rigi = f(7, ii)*bet*bet/qi*1.e03
24907 if (ichaes .and. l>0.)
then 24908 if (sce10==1 .or. sce10==3.)
then 24910 write (16, *)
'space charge at the middle of the lens' 24921 gpai = f(7, i)/xmat
24922 bcour = sqrt(1.-1./(gpai*gpai)) + bcour
24924 bcour = bcour/float(ngood)
24925 gcour = 1./sqrt(1.-bcour*bcour)
24926 wcg = (gcour-1.)*xmat
24928 tref = tref + xlqua/(2.*vref)
24935 gpa = f(7, ii)/xmat
24936 bet = sqrt(gpa*gpa-1.)/gpa
24938 rigi = f(7, ii)*bet*bet/qi*1.e03
24945 tref = tref + xlqua/(2.*vref)
24947 ilost = ilost + nlost
24951 if (itvol) ttvols = tref
24953 call stapl(davtot*10.)
24956 tcog = tcog + f(6, i)
24958 tcog = tcog/float(ngood)
24960 write (16, 11) ttvols*fcpi, davtot, tref*fcpi, tcog*fcpi
24961 11
format (
' ** tof for adjustments: ', e12.5,
' deg at position: ', e12.5,
' cm in the lattice', /, 3x, &
24962 'tof of the reference: ', e12.5,
' deg tof of the cog: ', e12.5,
' deg')
24964 write (16, 12) tref*fcpi, tcog*fcpi
24965 12
format (
' ** tof of the reference: ', e12.5,
' deg tof of the cog: ', e12.5,
' deg')
24967 dav1(idav, 36) = ngood
24968 write (16, *)
' particles lost :', ilost
24971 if (abs(volt)>1.e-13)
then 24976 if (iemgrw)
call emiprt(0)
24978 call stapl(davtot*10.)
24980 end subroutine qelec 24991 subroutine qfk(ityqu, arg, xlqua, rs)
24992 implicit real *8(a-h, o-z)
24993 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
24994 common /fene/wdisp, wphas, wx, wy, rlim, ifw
24995 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
24996 common /dyn/tref, vref
24997 common /consta/vl, pi, xmat, rpel, qst
24999 common /faisc/f(10, iptsz), imax, ngood
25000 common /etcom/cog(8), exten(17), fd(iptsz)
25001 common /qmoyen/qmoy
25004 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
25006 common /tapes/in, ifile, meta
25007 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
25008 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
25009 common /shif/dtiph, shift
25011 common /compt/nrres, nrtre, nrbunc, nrdbun
25012 common /rander/ialin
25014 common /qskew/qtwist, iqrand, itwist, iaqu
25016 common /femt/iemgrw, iemqesg
25018 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
25019 common /qsex/l, kq2, ks2
25020 common /tofev/ttvols
25021 common /itvole/itvol, imamin
25023 logical itvol, imamin, ityq
25024 real *8 l, kq2, ks2
25029 if (ityqu==0) ityq = .true.
25030 if (ityqu/=0) ityq = .false.
25032 write (16, *)
' ***QUADRUPOLE (electrostatic)***' 25034 write (16, *)
' ***QUADRUPOLE (magnetic)***' 25037 if (iprf==1)
call stapl(davtot*10.)
25040 if (itvol)
write (16, 10) ttvols*fcpi, davtot
25041 10
format (
' ** tof at input: ', e12.5,
' deg position in the lattice: ', e12.5,
' cm ')
25045 write (6, 8254) nrtre, nrres, cr
25046 8254
format (
'Transport element:', i5,
' Accelerating element:', i5, a1, $)
25051 if (abs(xfqu)>1.e-13)
then 25053 if (iqrand==0)
then 25059 call rlux(trans, len)
25060 if (trans(1)<=rdcf) sign = -1.
25061 if (trans(1)>rdcf) sign = 1.
25062 call rlux(trans, len)
25063 qtwrad = qtwist*sign*trans(1)
25073 dav1(idav, 1) = xlqua*10.
25074 davtot = davtot + xlqua
25075 dav1(idav, 4) = davtot*10.
25079 gpa = gpa + f(7, ii)/xmat
25081 gpa = gpa/float(ngood)
25082 bet = sqrt(gpa*gpa-1.)/gpa
25089 rigid = eni*bet*bet/qi*1.e03
25091 volt = xfqu*rs*rs*rigid
25097 dav1(idav, 2) = volt
25098 dav1(idav, 3) = rigid
25099 dav1(idav, 5) = xgrad
25100 dav1(idav, 6) = xfqu
25101 dav1(idav, 7) = rs*10.
25104 write (16, 100) xlqua, rs, volt, xfqu, xgrad, rigid
25105 100
format (
' LENGTH = ', e12.5,
' cm APERTURE RADIUS= ', e12.5,
' cm', /,
' VOLTAGE = ', e12.5,
' kV K2 = ', &
25106 e12.5,
' cm-2 GRADIENT = ', e12.5,
' kV/cm2', /,
' MOMENTUM = ', e12.5,
' kV', /)
25111 if (.not. ityq)
then 25112 xmco = xmat*bet*gpa
25114 rigid = 33.356*xmco*1.e-01/qst
25120 dav1(idav, 2) = bgaus
25121 dav1(idav, 3) = rigid
25122 dav1(idav, 5) = bgrad
25123 dav1(idav, 6) = xfqu
25124 dav1(idav, 7) = rs*10.
25127 write (16, 3300) xlqua, rs, bgaus, xfqu, bgrad, rigid
25128 3300
format (
' LENGTH = ', e12.5,
' cm APERTURE RADIUS= ', e12.5,
' cm', /,
' FIELD = ', e12.5,
' kG K2 = ', &
25129 e12.5,
' cm-2 GRADIENT = ', e12.5,
' kG/cm', /,
' MOMENTUM = ', e12.5,
' kG.cm', /)
25136 gpa = f(7, ii)/xmat
25137 bet = sqrt(gpa*gpa-1.)/gpa
25142 rigi = f(7, ii)*bet*bet/qi*1.e03
25149 if (.not. ityq)
then 25150 xmco = xmat*bet*gpa
25152 rigi = 3.3356*xmco/f(9, ii)
25160 if (ichaes .and. l>0.)
then 25161 if (sce10==1 .or. sce10==3.)
then 25163 write (16, *)
'space charge at the middle ' 25174 gpai = f(7, i)/xmat
25175 bcour = sqrt(1.-1./(gpai*gpai)) + bcour
25177 bcour = bcour/float(ngood)
25178 gcour = 1./sqrt(1.-bcour*bcour)
25179 wcg = (gcour-1.)*xmat
25181 tref = tref + xlqua/(2.*vref)
25188 gpa = f(7, ii)/xmat
25189 bet = sqrt(gpa*gpa-1.)/gpa
25194 rigi = f(7, ii)*bet*bet/qi*1.e03
25201 if (.not. ityq)
then 25202 xmco = xmat*bet*gpa
25204 rigi = 3.3356*xmco/f(9, ii)
25213 tref = tref + xlqua/(2.*vref)
25215 ilost = ilost + nlost
25219 if (itvol) ttvols = tref
25221 call stapl(davtot*10.)
25224 tcog = tcog + f(6, i)
25226 tcog = tcog/float(ngood)
25228 write (16, 11) ttvols*fcpi, davtot, tref*fcpi, tcog*fcpi
25229 11
format (
' ** tof for adjustments: ', e12.5,
' deg at position: ', e12.5,
' cm in the lattice', /, 3x, &
25230 'tof of the reference: ', e12.5,
' deg tof of the cog: ', e12.5,
' deg')
25232 write (16, 12) tref*fcpi, tcog*fcpi
25233 12
format (
' ** tof of the reference: ', e12.5,
' deg tof of the cog: ', e12.5,
' deg')
25235 dav1(idav, 36) = ngood
25236 write (16, *)
' particles lost :', ilost
25239 if (abs(xfqu)>1.e-13)
then 25244 if (iemgrw)
call emiprt(0)
25246 call stapl(davtot*10.)
25257 implicit real *8(a-h, o-z)
25258 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
25259 common /ttfs/dynt(maxcell), dyntp(maxcell), dyntpp(maxcell), dyne0(maxcell), dynph(maxcell), dynlg(maxcell), &
25262 common /midgap/enmil, vapmi
25263 common /azmtch/dlg, xmcph, xmce
25264 common /azlist/icont, iprin
25265 common /itvole/itvol, imamin
25266 common /func/a(200), ylg, atte, ncel, nharm
25267 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
25269 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
25270 common /faisc/f(10, iptsz), imax, ngood
25271 common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
25272 common /cavnum1/xnh, xpas, ffield, npt
25273 common /cavnum2/b0, b1, b2, b3, b4, b5
25274 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
25275 common /rfield/ifield
25276 common /qmoyen/qmoy
25278 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
25279 common /consta/vl, pi, xmat, rpel, qst
25280 common /dyn/tref, vref
25281 common /compt/nrres, nrtre, nrbunc, nrdbun
25282 common /compt1/ndtl, ncavmc, ncavnm
25283 common /fene/wdisp, wphas, wx, wy, rlim, ifw
25284 common /tapes/in, ifile, meta
25285 common /etcom/cog(8), exten(17), fd(iptsz)
25286 common /speda/dave, idave
25287 common /shif/dtiph, shift
25288 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
25289 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
25291 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
25292 common /appel/irstay, ilost, iavp, ispcel
25293 common /femt/iemgrw, iemqesg
25294 common /mode/eflvl, rflvl
25295 common /aerp/vphase, vfield, ierpf
25296 common /tofev/ttvols
25301 common /xposi/xpost(10), xlce(2), xpax(2), iscx(2)
25302 common /kcell/avrg(15)
25307 common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
25308 common /t3dfld/fldctr(15), zend(15), t3d
25312 character *128 trace3h, trace3t, tif
25314 common /xitrd3/bcour1(15), bcour2(15), tr3dw(15), tr3ph(15), t0tr3d(15)
25316 logical iesp, ichaes, irstay, iavp, ispcel, ifield, iemgrw
25317 logical shift, chasit, itvol, imamin, dave, jelec
25324 ncavnm = ncavnm + 1
25327 write (6, 8254) nrtre, nrres, cr
25328 8254
format (
'Transport element:', i5,
' Accelerating element:', i5, a1, $)
25329 write (16, *)
' CAVITY N :', nrres
25344 read (in, *) dielec, dphase, ffield, istep, ielec
25347 if (ncavnm==1)
write (13, 990)
25348 990
format (3x,
'ncav', 2x,
'ncell', 2x,
'pos I(cm)', 4x,
'pos S(cm)', 6x,
'L cell(cm)', 5x,
'W(Mev)', 7x,
'dw(Mev)', &
25349 6x,
'TOF(dg)', 7x,
'Ph RF(dg)', 5x,
'avrg pos(cm)')
25350 if (ncavnm==1)
write (13, 995)
25351 995
format (3x,
'ncell', 3x,
'E0TL(Mev)', 4x,
'T(k) Mev/q', 4x,
'S(k) Mev/q', 5x,
'dW(Mev)', 6x,
'PHASE(dg)', 5x, &
25355 if (ielec==0) jelec = .true.
25356 ffield = 1. + ffield/100.
25357 if (ffield==0.) ffield = 1.e-12
25367 flength = xspl(npt) - xspl(1)
25377 if (itvol .and. imamin)
then 25379 ottvol = fh*ttvols*180./pi
25383 xkpi = (xkpi-float(ixkpi))*360.
25384 dphase = dphase - xkpi
25386 write (16, 150) fh/(2.*pi), ylg, atte, ffield, ncel, istep
25387 150
format (4x,
'FREQUENCY :', e12.5,
' Hertz', /, 4x,
'FIELD LENGTH :', e12.5,
' cm', /, 4x, &
25388 'FIELD FACTOR (UNITS CONVERSION) :', e12.5, /, 4x,
'FIELD FACTOR (ATTENUATION) :', e12.5, /, 4x, &
25389 'FIELD DIVIDED IN: ', i4,
' CELLS STEPS BY CELL ', i5)
25390 if (.not. imamin)
write (16, *)
' PHASE OFFSET: ', dphete,
' DEG' 25391 if (imamin)
write (16, 1501) dphete, dphase, xkpi
25392 1501
format (4x,
'PHASE OFFSET (before adjustment): ', e12.5,
' deg', /, 4x,
'PHASE OFFSET (after adjustment): ', &
25393 e12.5,
' deg', /, 4x,
'ADJUSTMENT ON THE PHASE OFFSET: ', e12.5,
' deg')
25398 if (itvol) ttvol = ttvols*fh
25405 dav1(idav, 1) = ylg*10.
25406 dav1(idav, 2) = ye0*100.
25407 davtot = davtot + ylg
25408 dav1(idav, 24) = davtot*10.
25409 dav1(idav, 40) = fh
25410 if (iprf==1)
call stapl(dav1(idav,24))
25416 bcog = sqrt(1.-1./(gcog*gcog))
25421 gamref = 1./sqrt(1.-(beref*beref))
25422 enref = xmat*gamref
25423 trefdg = tref*fh*180./pi
25434 if (dav1(idav,3)==1.)
write (16, *)
' ****reference and cog evolve independently' 25435 if (dav1(idav,3)==0.)
write (16, *)
' **** the reference is the cog ' 25437 178
format (/,
' Dynamics at the input', /, 5x,
' BETA GAMMA ENERGY(MeV) ',
' TOF(deg) TOF(sec)')
25438 write (16, 1788) bcog, gcog, encog - xmat, tcog*fh*180./pi, tcog
25439 1788
format (
' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
25440 enrprin = enref - xmat
25441 write (16, 165) beref, gamref, enrprin, tref*fh*180./pi, tref
25442 165
format (
' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
25447 tk =
tta0(beref)/2.*ffield
25448 sk =
tsb0(beref)/2.*ffield
25450 pcrest = atan(-sk/tk)
25451 ddwc = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
25452 if (ddwc<0.) pcrest = pcrest + pi
25454 call phcrest(pcrest, ylg, ncell, zcrest)
25456 avbet = fh/(zcrest*vl)
25457 tk =
tta0(avbet)/2.*ffield
25458 sk =
tsb0(avbet)/2.*ffield
25459 pcrest = atan(-sk/tk)
25460 ddwc = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
25461 if (ddwc<0.) pcrest = pcrest + pi
25465 dphase = dphase*pi/180.
25466 phi0 = pcrest + dphase + ttvol
25469 call dwref(phi0, gams, ts)
25476 trphase = tr3ph(klm)
25477 tre0tl = t0tr3d(klm)/aqst
25482 write (tif, 6001) kt3t, kt3t, 10.*fldctr(klm)
25483 6001
format (
' nt(', i4,
')= 1, a(1,', i4,
')=', f12.6)
25484 trace3t(kt3t) = tif
25488 write (tif, 6005) kt3t, kt3t, tre0tl, trphase, fid
25489 6005
format (
' nt(', i4,
')=10, a(1,', i4,
')=', f9.5,
' , ', f9.2,
', 0., 1.,', f5.3,
',')
25490 trace3t(kt3t) = tif
25494 write (tif, 6001) kt3t, kt3t, 10.*zend(klm)
25495 trace3t(kt3t) = tif
25501 bets = sqrt(gams*gams-1.)/gams
25503 tredg = fh*trefs*180./pi
25505 call bcnum(phi0, ylg, ncell)
25509 gcg = gcg + f(7, i)/xmat
25511 gcg = gcg/float(ngood)
25512 bcg = sqrt(1.-1./(gcg*gcg))
25513 wcg = (gcg-1.)*xmat
25517 gpai = f(7, i)/xmat
25518 if (gpai<1.) gpai = 1.
25519 bpai = sqrt(1.-1./(gpai*gpai))
25520 fd(i) = bpai/bcg*gpai/gcg
25530 write (16, *)
' PARAMETERS RELATING TO THE REFERENCE PARTICLE ' 25531 write (16, *)
'***********************************************' 25532 write (16, *)
' ENERGY GAIN(MeV) ', ddw,
' TOF ', tredg,
' DEG' 25533 write (16, *)
' PHASE OF RF AT ENTRANCE(DG) ', phi0*180./pi
25534 write (16, *)
' CREST PHASE OF RF (DEG) ', pcrest*180./pi
25539 bcog = sqrt(1.-1./(gcog*gcog))
25547 dav1(idav, 38) = dphete
25548 dav1(idav, 39) = dphase*180./pi
25550 dav1(idav, 38) = dphete
25553 3777
format (/,
' Dynamics at the output', /, 5x,
' BETA dW(MeV) ENERGY(MeV) ',
' TOF(deg) TOF(sec)')
25554 engain = encog - enold
25555 write (16, 3473) bets, ddw, enrs - xmat, fh*trefs*180./pi, trefs
25556 3473
format (
' REF ', f7.5, 3x, f10.6, 3x, e12.5, 3x, e12.5, 3x, e12.5)
25557 write (16, 1789) bcog, engain, encog - xmat, tcog*fh*180./pi, tcog
25558 1789
format (
' COG ', f7.5, 3x, f10.6, 3x, e12.5, 3x, e12.5, 3x, e12.5)
25559 testca = exten(1)*exten(2)*exten(3)
25562 if (abs(testca)>epsil)
then 25563 qdisp = 2.*sqrt(exten(1))
25564 qmd = exten(1)*exten(3) - exten(2)**2
25565 sqmdv = 4.*pi*sqrt(qmd)
25566 surm = 4.*pi*sqrt(qmd)*180./pi
25567 qdp = 2.*sqrt(exten(3))
25568 cor12 = exten(2)/sqrt(exten(1)*exten(3))
25571 qdpde = qdp*180./pi
25583 trqtx = exten(4)*exten(5) - exten(8)**2
25584 trqpy = exten(6)*exten(7) - exten(9)**2
25585 qditax = 2.*sqrt(exten(4))
25586 qdiant = 2.*sqrt(exten(5))
25587 qditay = 2.*sqrt(exten(6))
25588 qdianp = 2.*sqrt(exten(7))
25589 surxth = 4.*pi*sqrt(trqtx)
25590 suryph = 4.*pi*sqrt(trqpy)
25598 if (itvol) ttvols = tref
25601 call stapl(dav1(idav,24))
25605 dav1(idav, 16) = bcog*surxth*10./(pi*sqrt(1.-bcog*bcog))
25608 dav1(idav, 21) = bcog*suryph*10./(pi*sqrt(1.-bcog*bcog))
25609 dav1(idav, 25) = nrres
25610 dav1(idav, 30) = ngood
25618 emns = 1.e12*sqmdv/(pi*fh)
25620 trfprt = fh*tref*180./pi
25621 tcgprt = fh*tcog*180./pi
25631 trnsms = 100.*float(ngood)/float(imax)
25632 if (ncavnm==1)
write (50, *)
'# cavnum.dmp' 25633 if (ncavnm==1)
write (50, *)
'# cav Z trans ', &
25634 'PHIs TOF(COG) COG Wcog TOF(REF) ', &
25635 ' REF Wref Ex,RMS,n Ey,RMS,n El,RMS' 25636 if (ncavnm==1)
write (50, *)
'# # (m) (%) ', &
25637 '(deg) (deg) beta (MeV) (deg) ', &
25638 ' beta (MeV) (mm.mrad) (mm.mrad) (ns.keV)' 25639 write (50, 7023) nrres, 0.001*dav1(idav, 24), trnsms, dphete, tcgprt, bcog, encog - xmat, trfprt, bets, &
25640 enrs - xmat, 0.25*dav1(idav, 16), 0.25*dav1(idav, 21), 0.25*emns
25641 7023
format (1x, i4, 1x, e12.5, 1x, f6.2, 1x, f7.2, 1x, 2(e14.7,1x,f7.5,1x,e14.7,1x), 3(e12.5,1x))
25645 gref = 1./sqrt(1.-bets*bets)
25646 xmor = xmat*bets*gref
25647 boro = 33.356*xmor*1.e-01/aqst
25648 write (16, *) ilost,
' particles lost in cavity ', nrres
25657 subroutine phcrest(phi0, ylg, ncell, zcrest)
25658 implicit real *8(a-h, o-z)
25659 common /cavnum1/xnh, xpas, fmult, npt
25660 common /cavnum2/b0, b1, b2, b3, b4, b5
25661 common /cavnum3/bgt0, bgt1, bgt2, bgt3, bgt4, bgt5
25662 common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
25663 common /consta/vl, pi, xmat, rpel, qst
25664 common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
25665 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
25666 common /dyn/tref, vref
25670 xpas = ylg/float(npas)
25679 gam0 = 1./sqrt(1.-b0*b0)
25685 if (xpat<(ylg-estop))
then 25694 dgam =
xi1(phi0, t0, t5)*qst/e0
25698 dgdz = qst/e0*tspl0
25699 d2gdz2 = dgam/xpas2 - dgdz/xpas
25701 gam1 = gam0 + dgdz*xpas/5. + d2gdz2*xpas2/50.
25702 gam2 = gam0 + dgdz*xpas*2./5. + d2gdz2*xpas2*4./50.
25703 gam3 = gam0 + dgdz*xpas*3./5. + d2gdz2*xpas2*9./50.
25704 gam4 = gam0 + dgdz*xpas*4./5. + d2gdz2*xpas2*16./50.
25705 b1 = sqrt(gam1*gam1-1.)/gam1
25706 b2 = sqrt(gam2*gam2-1.)/gam2
25707 b3 = sqrt(gam3*gam3-1.)/gam3
25708 b4 = sqrt(gam4*gam4-1.)/gam4
25709 b5 = sqrt(gam5*gam5-1.)/gam5
25710 dgam =
xi1(phi0, t0, t5)*qst/e0
25712 b5 = sqrt(gam5*gam5-1.)/gam5
25728 subroutine phcrest1(phi0, ylg, ncell)
25729 implicit real *8(a-h, o-z)
25730 common /cavnum1/xnh, xpas, fmult, npt
25731 common /cavnum2/b0, b1, b2, b3, b4, b5
25732 common /cavnum3/bgt0, bgt1, bgt2, bgt3, bgt4, bgt5
25733 common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
25734 common /consta/vl, pi, xmat, rpel, qst
25735 common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
25736 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
25737 common /dyn/tref, vref
25738 dimension stx(400), sty(400), sts(400), stp(400), stq(400)
25739 dimension phc(100), wph(100)
25742 xpas = ylg/float(npas)
25748 pmax = phi0 + 10.*rad
25749 pmin = phi0 - 10.*rad
25753 if (phi>=pmax)
go to 50
25762 gam0 = 1./sqrt(1.-b0*b0)
25763 wwref = (gam0-1.)*e0
25766 if (xnh*xpas>=ylg)
go to 10
25775 dgam =
xi1(phi, t0, t5)*qst/e0
25779 dgdz = qst/e0*tspl0
25780 d2gdz2 = dgam/(xpas2) - dgdz/xpas
25782 gam1 = gam0 + dgdz*xpas/5. + d2gdz2*xpas2/50.
25783 gam2 = gam0 + dgdz*xpas*2./5. + d2gdz2*xpas2*4./50.
25784 gam3 = gam0 + dgdz*xpas*3./5. + d2gdz2*xpas2*9./50.
25785 gam4 = gam0 + dgdz*xpas*4./5. + d2gdz2*xpas2*16./50.
25786 b1 = sqrt(gam1*gam1-1.)/gam1
25787 b2 = sqrt(gam2*gam2-1.)/gam2
25788 b3 = sqrt(gam3*gam3-1.)/gam3
25789 b4 = sqrt(gam4*gam4-1.)/gam4
25790 b5 = sqrt(gam5*gam5-1.)/gam5
25791 dgam =
xi1(phi, t0, t5)*qst/e0
25793 b5 = sqrt(gam5*gam5-1.)/gam5
25800 wwpcr = (gam0-1.)*e0
25801 dwcpr = wwpcr - wwref
25824 yfb =
slope(ibcl, phi)/100.
25826 if (phi>=xspl(ibcl))
go to 60
25827 if (dph1<=dplim)
go to 60
25828 yf =
slope(ibcl, phi)
25857 subroutine dwref(phi0, gam5, t5)
25858 implicit real *8(a-h, o-z)
25859 common /cavnum1/xnh, xpas, fmult, npt
25860 common /cavnum2/b0, b1, b2, b3, b4, b5
25861 common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
25862 common /cavnum7/sspl0, sspl1, sspl2, sspl3, sspl4, sspl5
25863 common /consta/vl, pi, xmat, rpel, qst
25864 common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
25865 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
25866 common /dyn/tref, vref
25867 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
25869 common /compt/nrres, nrtre, nrbunc, nrdbun
25870 common /kcell/avrg(15)
25871 common /xitrd3/bcour1(15), bcour2(15), tr3dw(15), tr3ph(15), t0tr3d(15)
25872 common /sphi/tcour1(15), tcour2(15)
25873 common /t3dfld/fldctr(15), zend(15), t3d
25898 xlcel = xlim(inc+1) - xlim(inc)
25899 xlpos = xlpos + xlcel
25900 xpas = xlcel/float(isce)
25903 gam0 = 1./sqrt(1.-b0*b0)
25908 if (xpat<(xlcel-estop))
then 25917 dgam =
xi1(phi0, t0, t5)*qst/e0
25921 dgdz = qst/e0*tspl0
25922 d2gdz2 = dgam/xpas2 - dgdz/xpas
25924 gam1 = gam0 + dgdz*xpas/5. + d2gdz2*xpas2/50.
25925 gam2 = gam0 + dgdz*xpas*2./5. + d2gdz2*xpas2*4./50.
25926 gam3 = gam0 + dgdz*xpas*3./5. + d2gdz2*xpas2*9./50.
25927 gam4 = gam0 + dgdz*xpas*4./5. + d2gdz2*xpas2*16./50.
25928 b1 = sqrt(gam1*gam1-1.)/gam1
25929 b2 = sqrt(gam2*gam2-1.)/gam2
25930 b3 = sqrt(gam3*gam3-1.)/gam3
25931 b4 = sqrt(gam4*gam4-1.)/gam4
25932 b5 = sqrt(gam5*gam5-1.)/gam5
25933 dgam =
xi1(phi0, t0, t5)*qst/e0
25935 eww = xmat*(gam5-1.)
25937 wdgams = wdgams + wdgam
25939 b5 = sqrt(gam5*gam5-1.)/gam5
25948 xlcum = xlcum + xlcel
25949 ttvol = t5*fh*180./pi
25950 ttphi = ttvol + tref*fh*180/pi
25952 tr3dw(inc) = wdgams
25954 write (13, 101) nrres, inc, xlim(inc), xlim(inc+1), xlcel, eww, wdgams, ttvol, ttphi, avrg(inc)
25955 101
format (2(2x,i4), 8(2x,e12.5))
25956 fldctr(inc) = avrg(inc) - xlim(inc)
25957 zend(inc) = xlcel - fldctr(inc)
25963 end subroutine dwref 25968 implicit real *8(a-h, o-z)
25969 common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
25970 common /consta/vl, pi, xmat, rpel, qst
25971 common /xitrd3/bcour1(15), bcour2(15), tr3dw(15), tr3ph(15), t0tr3d(15)
25972 common /cavnum1/xnh, xpas, ffield, npt
25973 common /sphi/tcour1(15), tcour2(15)
25974 common /kcell/avrg(15)
25975 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
25976 dimension ttr3d(15), str3d(15)
25979 bcour = (bcour1(nrc)+bcour2(nrc))/2.
25980 ttr3d(nrc) =
ta0(bcour, nrc)
25983 bcour = (bcour1(nrc)+bcour2(nrc))/2.
25984 str3d(nrc) =
sb0(bcour, nrc)
25987 t0tr3d(nrc) = qst*sqrt(ttr3d(nrc)**2+str3d(nrc)**2)*ffield/2.
25989 tt = tr3dw(nrc)/t0tr3d(nrc)
25990 tph = atan(-str3d(nrc)/ttr3d(nrc))
25991 if (tt<1.) atr3d = acos(tt)
25992 ddw = ttr3d(nrc)*cos(tph) - str3d(nrc)*sin(tph)
25997 drift1 = avrg(nrc) - xlim(nrc)
25998 drift2 = xlim(nrc+1) - avrg(nrc)
25999 xsign1 = tcour2(nrc) - tcour1(nrc)
26000 xsing = xsign1 - (drift1/bcour1(nrc)+drift2/bcour2(nrc))/vl
26001 if (xsing>0.) atr3d = -atr3d
26002 tr3ph(nrc) = atr3d*180./pi
26003 write (13, 100) nrc, t0tr3d(nrc), ttr3d(nrc), str3d(nrc), tr3dw(nrc), atr3d*180./pi, tph*180./pi
26004 100
format (2x, i4, 6(2x,e12.5))
26007 end subroutine itrd3 26013 subroutine fposbbb(xlcum, fposs, jx)
26014 implicit real *8(a-h, o-z)
26015 common /cavnum1/xnh, xpas, fmult, npt
26016 common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26017 common /cavnum6/fpos0, fpos1, fpos2, fpos3, fpos4, fpos5
26018 common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
26019 common /rfield/ifield
26020 common /xposi/xpost(10), xlce(2), xpax(2), iscx(2)
26023 if (fposs==0.)
then 26024 fpos0 = xnh*xpas + xlcum + fposs
26025 fpos1 = (xnh+0.20)*xpas + xlcum + fposs
26026 fpos2 = (xnh+0.40)*xpas + xlcum + fposs
26027 fpos3 = (xnh+0.60)*xpas + xlcum + fposs
26028 fpos4 = (xnh+0.80)*xpas + xlcum + fposs
26029 fpos5 = (xnh+1.0)*xpas + xlcum + fposs
26031 fpos0 = xnh*xpas + fposs
26032 fpos1 = (xnh+0.20)*xpas + fposs
26033 fpos2 = (xnh+0.40)*xpas + fposs
26034 fpos3 = (xnh+0.60)*xpas + fposs
26035 fpos4 = (xnh+0.80)*xpas + fposs
26036 fpos5 = (xnh+1.0)*xpas + fposs
26040 if (xnh1==float(iscx(jx))) fposs = fpos5
26044 tspl0 =
spline(npt, fpos0)*fmult
26045 tspl1 =
spline(npt, fpos1)*fmult
26046 tspl2 =
spline(npt, fpos2)*fmult
26047 tspl3 =
spline(npt, fpos3)*fmult
26048 tspl4 =
spline(npt, fpos4)*fmult
26049 tspl5 =
spline(npt, fpos5)*fmult
26064 tspl0 =
fone(fpos0)*fmult
26065 tspl1 =
fone(fpos1)*fmult
26066 tspl2 =
fone(fpos2)*fmult
26067 tspl3 =
fone(fpos3)*fmult
26068 tspl4 =
fone(fpos4)*fmult
26069 tspl5 =
fone(fpos5)*fmult
26088 subroutine fposbb(xlcum)
26089 implicit real *8(a-h, o-z)
26090 common /cavnum1/xnh, xpas, fmult, npt
26091 common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26092 common /cavnum6/fpos0, fpos1, fpos2, fpos3, fpos4, fpos5
26093 common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
26094 common /rfield/ifield
26097 fpos0 = xnh*xpas + xlcum
26098 fpos1 = (xnh+0.20)*xpas + xlcum
26099 fpos2 = (xnh+0.40)*xpas + xlcum
26100 fpos3 = (xnh+0.60)*xpas + xlcum
26101 fpos4 = (xnh+0.80)*xpas + xlcum
26102 fpos5 = (xnh+1.0)*xpas + xlcum
26105 tspl0 =
spline(npt, fpos0)*fmult
26106 tspl1 =
spline(npt, fpos1)*fmult
26107 tspl2 =
spline(npt, fpos2)*fmult
26108 tspl3 =
spline(npt, fpos3)*fmult
26109 tspl4 =
spline(npt, fpos4)*fmult
26110 tspl5 =
spline(npt, fpos5)*fmult
26124 tspl0 =
fone(fpos0)*fmult
26125 tspl1 =
fone(fpos1)*fmult
26126 tspl2 =
fone(fpos2)*fmult
26127 tspl3 =
fone(fpos3)*fmult
26128 tspl4 =
fone(fpos4)*fmult
26129 tspl5 =
fone(fpos5)*fmult
26148 implicit real *8(a-h, o-z)
26149 common /cavnum1/xnh, xpas, fmult, npt
26150 common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26151 common /cavnum6/fpos0, fpos1, fpos2, fpos3, fpos4, fpos5
26152 common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
26153 common /rfield/ifield
26157 fpos1 = (xnh+0.20)*xpas
26158 fpos2 = (xnh+0.40)*xpas
26159 fpos3 = (xnh+0.60)*xpas
26160 fpos4 = (xnh+0.80)*xpas
26161 fpos5 = (xnh+1.0)*xpas
26164 tspl0 =
spline(npt, fpos0)*fmult
26165 tspl1 =
spline(npt, fpos1)*fmult
26166 tspl2 =
spline(npt, fpos2)*fmult
26167 tspl3 =
spline(npt, fpos3)*fmult
26168 tspl4 =
spline(npt, fpos4)*fmult
26169 tspl5 =
spline(npt, fpos5)*fmult
26183 tspl0 =
fone(fpos0)*fmult
26184 tspl1 =
fone(fpos1)*fmult
26185 tspl2 =
fone(fpos2)*fmult
26186 tspl3 =
fone(fpos3)*fmult
26187 tspl4 =
fone(fpos4)*fmult
26188 tspl5 =
fone(fpos5)*fmult
26201 end subroutine fposb 26208 implicit real *8(a-h, o-z)
26209 common /cavnum1/xnh, xpas, fmult, npt
26210 common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26211 common /cavnum6/fpos0, fpos1, fpos2, fpos3, fpos4, fpos5
26212 common /cavnum7/sspl0, sspl1, sspl2, sspl3, sspl4, sspl5
26213 common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
26214 common /rfield/ifield
26218 fpos1 = (xnh+0.20)*xpas
26219 fpos2 = (xnh+0.40)*xpas
26220 fpos3 = (xnh+0.60)*xpas
26221 fpos4 = (xnh+0.80)*xpas
26222 fpos5 = (xnh+1.0)*xpas
26225 sspl0 =
slope(npt, fpos0)*fmult
26226 sspl1 =
slope(npt, fpos1)*fmult
26227 sspl2 =
slope(npt, fpos2)*fmult
26228 sspl3 =
slope(npt, fpos3)*fmult
26229 sspl4 =
slope(npt, fpos4)*fmult
26230 sspl5 =
slope(npt, fpos5)*fmult
26244 tspl0 =
fone(fpos0)*fmult
26245 tspl1 =
fone(fpos1)*fmult
26246 tspl2 =
fone(fpos2)*fmult
26247 tspl3 =
fone(fpos3)*fmult
26248 tspl4 =
fone(fpos4)*fmult
26249 tspl5 =
fone(fpos5)*fmult
26262 end subroutine sposb 26267 function xi1(phi0, t0, t5)
26268 implicit real *8(a-h, o-z)
26269 common /cavnum1/xnh, xpas, fmult, npt
26270 common /cavnum2/b0, b1, b2, b3, b4, b5
26271 common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26272 common /consta/vl, pi, xmat, rpel, qst
26273 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
26281 t1 = t0 + xpas/(5.*b01*vl)
26282 t2 = t1 + xpas/(5.*b12*vl)
26283 t3 = t2 + xpas/(5.*b23*vl)
26284 t4 = t3 + xpas/(5.*b34*vl)
26285 t5 = t4 + xpas/(5.*b45*vl)
26286 xspl0 = cos(fh*t0+phi0)*tspl0
26287 xspl1 = cos(fh*t1+phi0)*tspl1
26288 xspl2 = cos(fh*t2+phi0)*tspl2
26289 xspl3 = cos(fh*t3+phi0)*tspl3
26290 xspl4 = cos(fh*t4+phi0)*tspl4
26291 xspl5 = cos(fh*t5+phi0)*tspl5
26292 tspl = 19.*xspl0 + 75.*xspl1 + 50.*xspl2 + 50.*xspl3 + 75.*xspl4 + 19.*xspl5
26293 xi1 = xpas/288.*tspl
26300 function xi2(phi0, t0)
26301 implicit real *8(a-h, o-z)
26302 common /cavnum1/xnh, xpas, fmult, npt
26303 common /cavnum2/b0, b1, b2, b3, b4, b5
26304 common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26305 common /consta/vl, pi, xmat, rpel, qst
26306 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
26313 t1 = t0 + xpas/(5.*b01*vl)
26314 t2 = t1 + xpas/(5.*b12*vl)
26315 t3 = t2 + xpas/(5.*b23*vl)
26316 t4 = t3 + xpas/(5.*b34*vl)
26317 t5 = t4 + xpas/(5.*b45*vl)
26319 xspl1 = cos(fh*t1+phi0)*tspl1
26320 xspl2 = cos(fh*t2+phi0)*tspl2
26321 xspl3 = cos(fh*t3+phi0)*tspl3
26322 xspl4 = cos(fh*t4+phi0)*tspl4
26323 xspl5 = cos(fh*t5+phi0)*tspl5
26324 tspl = 15.*xspl1 + 20.*xspl2 + 30.*xspl3 + 60*xspl4 + 19.*xspl5
26325 xi2 = xpas*xpas/288.*tspl
26332 function xj1(phi0, t0)
26333 implicit real *8(a-h, o-z)
26334 common /cavnum1/xnh, xpas, fmult, npt
26335 common /cavnum2/b0, b1, b2, b3, b4, b5
26336 common /cavnum3/bgt0, bgt1, bgt2, bgt3, bgt4, bgt5
26337 common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26338 common /consta/vl, pi, xmat, rpel, qst
26339 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
26347 t1 = t0 + xpas/(5.*b01*vl)
26348 t2 = t1 + xpas/(5.*b12*vl)
26349 t3 = t2 + xpas/(5.*b23*vl)
26350 t4 = t3 + xpas/(5.*b34*vl)
26351 t5 = t4 + xpas/(5.*b45*vl)
26352 xspl0 = -fh*sin(fh*t0+phi0)*tspl0/bgt0
26353 xspl1 = -fh*sin(fh*t1+phi0)*tspl1/bgt1
26354 xspl2 = -fh*sin(fh*t2+phi0)*tspl2/bgt2
26355 xspl3 = -fh*sin(fh*t3+phi0)*tspl3/bgt3
26356 xspl4 = -fh*sin(fh*t4+phi0)*tspl4/bgt4
26357 xspl5 = -fh*sin(fh*t5+phi0)*tspl5/bgt5
26358 tspl = 19.*xspl0 + 75.*xspl1 + 50.*xspl2 + 50.*xspl3 + 75.*xspl4 + 19.*xspl5
26359 xj1 = xpas/288.*tspl
26366 function xj2(phi0, t0)
26367 implicit real *8(a-h, o-z)
26368 common /cavnum1/xnh, xpas, fmult, npt
26369 common /cavnum2/b0, b1, b2, b3, b4, b5
26370 common /cavnum3/bgt0, bgt1, bgt2, bgt3, bgt4, bgt5
26371 common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26372 common /consta/vl, pi, xmat, rpel, qst
26373 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
26381 t1 = t0 + xpas/(5.*b01*vl)
26382 t2 = t1 + xpas/(5.*b12*vl)
26383 t3 = t2 + xpas/(5.*b23*vl)
26384 t4 = t3 + xpas/(5.*b34*vl)
26385 t5 = t4 + xpas/(5.*b45*vl)
26386 xspl1 = -fh*sin(fh*t1+phi0)*tspl1/bgt1
26387 xspl2 = -fh*sin(fh*t2+phi0)*tspl2/bgt2
26388 xspl3 = -fh*sin(fh*t3+phi0)*tspl3/bgt3
26389 xspl4 = -fh*sin(fh*t4+phi0)*tspl4/bgt4
26390 xspl5 = -fh*sin(fh*t5+phi0)*tspl5/bgt5
26391 tspl = 15.*xspl1 + 20.*xspl2 + 30.*xspl3 + 60.*xspl4 + 19.*xspl5
26392 xj2 = xpas*xpas/288.*tspl
26399 function xe21(phi0, t0)
26400 implicit real *8(a-h, o-z)
26401 common /cavnum1/xnh, xpas, fmult, npt
26402 common /cavnum2/b0, b1, b2, b3, b4, b5
26403 common /cavnum4/bge0, bge1, bge2, bge3, bge4, bge5
26404 common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26405 common /consta/vl, pi, xmat, rpel, qst
26406 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
26414 t1 = t0 + xpas/(5.*b01*vl)
26415 t2 = t1 + xpas/(5.*b12*vl)
26416 t3 = t2 + xpas/(5.*b23*vl)
26417 t4 = t3 + xpas/(5.*b34*vl)
26418 t5 = t4 + xpas/(5.*b45*vl)
26419 xspl0 = cos(fh*t0+phi0)*tspl0
26420 xspl1 = cos(fh*t1+phi0)*tspl1
26421 xspl2 = cos(fh*t2+phi0)*tspl2
26422 xspl3 = cos(fh*t3+phi0)*tspl3
26423 xspl4 = cos(fh*t4+phi0)*tspl4
26424 xspl5 = cos(fh*t5+phi0)*tspl5
26425 xspl0 = xspl0*xspl0*bge0
26426 xspl1 = xspl1*xspl1*bge1
26427 xspl2 = xspl2*xspl2*bge2
26428 xspl3 = xspl3*xspl3*bge3
26429 xspl4 = xspl4*xspl4*bge4
26430 xspl5 = xspl5*xspl5*bge5
26431 tspl = 19.*xspl0 + 75.*xspl1 + 50.*xspl2 + 50.*xspl3 + 75.*xspl4 + 19.*xspl5
26432 xe21 = xpas/288.*tspl
26439 function xe22(phi0, t0)
26440 implicit real *8(a-h, o-z)
26441 common /cavnum1/xnh, xpas, fmult, npt
26442 common /cavnum2/b0, b1, b2, b3, b4, b5
26443 common /cavnum4/bge0, bge1, bge2, bge3, bge4, bge5
26444 common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26445 common /consta/vl, pi, xmat, rpel, qst
26446 common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
26447 common /dyn/tref, vref
26448 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
26449 common /rfield/ifield
26458 t1 = t0 + xpas/(5.*b01*vl)
26459 t2 = t1 + xpas/(5.*b12*vl)
26460 t3 = t2 + xpas/(5.*b23*vl)
26461 t4 = t3 + xpas/(5.*b34*vl)
26462 t5 = t4 + xpas/(5.*b45*vl)
26463 xspl1 = cos(fh*t1+phi0)*tspl1
26464 xspl2 = cos(fh*t2+phi0)*tspl2
26465 xspl3 = cos(fh*t3+phi0)*tspl3
26466 xspl4 = cos(fh*t4+phi0)*tspl4
26467 xspl5 = cos(fh*t4+phi0)*tspl5
26468 xspl1 = xspl1*xspl1*bge1
26469 xspl2 = xspl2*xspl2*bge2
26470 xspl3 = xspl3*xspl3*bge3
26471 xspl4 = xspl4*xspl4*bge4
26472 xspl5 = xspl5*xspl5*bge5
26473 tspl = 15.*xspl1 + 20.*xspl2 + 30.*xspl3 + 60.*xspl4 + 19.*xspl5
26474 xe22 = xpas*xpas/288.*tspl
26481 subroutine bcnum(phref, ylg, ncell)
26482 implicit real *8(a-h, o-z)
26483 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
26484 common /dyn/tref, vref
26485 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
26487 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
26488 common /faisc/f(10, iptsz), imax, ngood
26489 common /consta/vl, pi, xmat, rpel, qst
26490 common /cavnum1/xnh, xpas, fmult, npt
26491 common /cavnum2/b0, b1, b2, b3, b4, b5
26492 common /cavnum3/bgt0, bgt1, bgt2, bgt3, bgt4, bgt5
26493 common /cavnum4/bge0, bge1, bge2, bge3, bge4, bge5
26494 common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26495 common /rfield/ifield
26496 common /testref/trefs, ddw
26499 dimension gam(500), xe(500), xpe(500), ye(500), ype(500)
26500 dimension tcour(iptsz), phi(iptsz)
26501 logical ifield, flgsc, ichaes, iesp, jelec
26505 gamref = 1./sqrt(1.-(beref*beref))
26506 enref = xmat*gamref
26509 xpas = ylg/float(npas)
26528 rphas = fh*(tof-tref)
26529 phi(j) = phref + rphas
26534 b0 = sqrt(gam0*gam0-1.)/gam0
26540 dgam =
xi1(phi(j), t0, t5)*qc/e0
26541 gam5 = gam(i1) + dgam
26545 dgdz = qst/e0*tspl0
26546 d2gdz2 = dgam/xpas2 - dgdz/xpas
26548 gam1 = gam0 + dgdz*xpas/5. + d2gdz2*xpas2/50.
26549 gam2 = gam0 + dgdz*xpas*2./5. + d2gdz2*xpas2*4./50.
26550 gam3 = gam0 + dgdz*xpas*3./5. + d2gdz2*xpas2*9./50.
26551 gam4 = gam0 + dgdz*xpas*4./5. + d2gdz2*xpas2*16./50.
26552 b1 = sqrt(gam1*gam1-1.)/gam1
26553 b2 = sqrt(gam2*gam2-1.)/gam2
26554 b3 = sqrt(gam3*gam3-1.)/gam3
26555 b4 = sqrt(gam4*gam4-1.)/gam4
26556 b5 = sqrt(gam5*gam5-1.)/gam5
26557 dgam =
xi1(phi(j), t0, t5)*qc/e0
26558 gam5 = gam(i1) + dgam
26559 b5 = sqrt(gam5*gam5-1.)/gam5
26563 xt0 = f(3, j)*1.e-03
26564 yp0 = f(5, j)*1.e-03
26566 gamm0 = (gam0*gam0-1.)**0.25
26571 xpe0 = xpe0 + .5*xe0*gam0*dgdz/(gam0*gam0-1.)
26572 ype0 = ype0 + .5*ye0*gam0*dgdz/(gam0*gam0-1.)
26583 bgt0 = (gam00-1.)**1.5
26584 xk1 = fh*fh/(4.*vl*vl*bgt0)
26585 red = sqrt(xe(i1)*xe(i1)+ye(i1)*ye(i1))
26588 if (red>1.e-08)
then 26589 dred = xe(i1)*xpe(i1) + ye(i1)*ype(i1)
26592 rk1 = xk1*red2*
xi1(phi(j), t0, t5)*qc/e0
26593 rk2 = red*dred*xk1*
xi2(phi(j), t0)*qc/e0
26594 gam(i) = gam5 + rk1 + rk2
26595 gam55 = gam(i)*gam(i)
26596 bgt1 = (gam11-1.)**1.5
26597 bgt2 = (gam22-1.)**1.5
26598 bgt3 = (gam33-1.)**1.5
26599 bgt4 = (gam44-1.)**1.5
26600 bgt5 = (gam55-1.)**1.5
26601 bge0 = (gam00+2.)/((gam00-1.)*(gam00-1.))
26602 bge1 = (gam11+2.)/((gam11-1.)*(gam11-1.))
26603 bge2 = (gam22+2.)/((gam22-1.)*(gam22-1.))
26604 bge3 = (gam33+2.)/((gam33-1.)*(gam33-1.))
26605 bge4 = (gam44+2.)/((gam44-1.)*(gam44-1.))
26606 bge5 = (gam55+2.)/((gam55-1.)*(gam55-1.))
26614 f(7, j) = gam(i)*e0
26617 f(6, j) = ddt1 + f(6, j)
26621 ttt1 =
xj1(phi(j), t0)
26622 ttt2 =
xj2(phi(j), t0)
26625 dxpe1 = xe(i1)*ttt1 + xpe(i1)*ttt2
26626 dype1 = ye(i1)*ttt1 + ype(i1)*ttt2
26627 xpe(i) = xpe(i1) + a1*dxpe1
26628 ype(i) = ype(i1) + a1*dype1
26633 stt1 =
xe21(phi(j), t0)
26634 stt2 =
xe22(phi(j), t0)
26635 dxpe2 = xe(i1)*stt1 + xpe(i1)*stt2
26636 dype2 = ye(i1)*stt1 + ype(i1)*stt2
26637 xpe(i) = xpe(i1) + a1*dxpe1 - ae2*dxpe2
26638 ype(i) = ype(i1) + a1*dype1 - ae2*dype2
26645 xe(i) = xe(i1) + xpas*(xpe(i1)+xpe(i))/2.
26646 ye(i) = ye(i1) + xpas*(ype(i1)+ype(i))/2.
26648 dgdzr = qc/e0*tspl5
26649 gamm1 = (gam(i)*gam(i)-1.)**0.25
26650 gamm2 = (gam(i)*gam(i)-1.)**1.25
26652 xpi = xpe(i)/gamm1 - xe(i)*gam(i)*dgdzr/(gamm2*2.)
26654 ypi = ype(i)/gamm1 - ye(i)*gam(i)*dgdzr/(gamm2*2.)
26658 f(3, j) = xpi*1.e03
26659 f(5, j) = ypi*1.e03
26662 if (.not. flgsc)
then 26681 end subroutine bcnum 26690 subroutine reject(ilost)
26691 implicit real *8(a-h, o-z)
26692 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
26693 common /consta/vl, pi, xmat, rpel, qst
26694 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
26695 common /faisc/f(10, iptsz), imax, ngood
26696 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
26697 common /mcs/imcs, ncstat, cstat(20)
26698 common /etcom/cog(8), exten(17), fd(iptsz)
26699 common /fene/wdisp, wphas, wx, wy, rlim, ifw
26700 common /dyn/tref, vref
26706 write (16, *)
'Check if the ', ngood,
' particles are within window' 26707 write (16, *)
'Number of charge states: ', ncstat
26713 if (ncstat>1)
call cogetc 26717 gpai = f(7, i)/xmat
26718 bcour = sqrt(1.-1./(gpai*gpai)) + bcour
26719 cgtv = cgtv + f(6, i)
26721 cgtv = cgtv/float(ngood)
26722 bcour = bcour/float(ngood)
26724 gcour = 1./sqrt(1.-bcour*bcour)
26726 wcg = (gcour-1.)*xmat
26728 gpai = f(7, i)/xmat
26729 if (gpai<1.) gpai = 1.
26730 bcour = sqrt(1.-1./(gpai*gpai))
26731 fd(i) = bcour/bcg*gpai/gcg
26734 dispr = gcour*gcour*wdisp/(gcour*(gcour+1.))
26736 dispr = gcour*gcour*wdisp/(gcour*(gcour+1.)*wcg)
26742 gref = 1./sqrt(1.-bref*bref)
26743 wref = (gref-1.)*xmat
26745 gpai = f(7, i)/xmat
26746 bcour = sqrt(1.-1./(gpai*gpai))
26747 fd(i) = bcour/bref*gpai/gref
26750 dispr = gref*gref*wdisp/(gref*(gref+1.))
26752 dispr = gref*gref*wdisp/(gref*(gref+1.)*wref)
26755 write (16, 3927) rlim, wx, wy, wphas, wdisp
26759 ray = f(2, i)*f(2, i) + f(4, i)*f(4, i)
26761 if (ray>rlim) f(8, i) = 0.
26762 if (abs(f(2,i))>wx) f(8, i) = 0.
26763 if (abs(f(4,i))>wy) f(8, i) = 0.
26768 do istc = 1, ncstat
26769 if (f(9,i)==charm(istc))
then 26770 f6i = f(6, i) - cgtdv(istc)
26775 f6i = f(6, i) - cgtv
26779 f6i = f(6, i) - tref
26781 if (fh*abs(f6i)>=wphas)
then 26785 if (abs(fd(i)-1.)>=dispr)
then 26789 if (f(8,i)==0.)
then 26790 write (16, 3928) i, int(f(1,i)), f(2, i), f(3, i), f(4, i), f(5, i), f6i*fh*180./pi, f(7, i) - xmat, f(9, i)
26802 if (f(9,j)==cstat(k))
then 26806 if (mcstat==0)
then 26807 ncstat = ncstat + 1
26808 cstat(ncstat) = f(9, j)
26812 write (16, *)
'Number of good particles left: ', ngood
26813 write (16, *)
'Number of charge states left : ', ncstat
26814 write (16, 4030)(cstat(j), j=1, ncstat)
26816 if (ncstat>1) imcs = 1
26817 3900
format (
' Window w.r.t. COG')
26818 3901
format (
' Window w.r.t. reference particle')
26819 3927
format (
' LIM R,X,Y ', 3(f10.2,9x),
'P,W ', e12.5, 9x, e12.5)
26820 3928
format (
' # ', i5, 1x, i5, 1x, 6(f10.2,1x), 1x, f5.2)
26821 4030
format (
'Charge state(s): ', 20(f5.1,1x))
26855 subroutine aimalv(angl, rmo, baim, xn, xb, ek1, ek2, pent1, rab1, sk1, sk2, pent2, rab2)
26856 implicit real *8(a-h, o-z)
26857 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
26858 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
26859 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
26860 common /fene/wdisp, wphas, wx, wy, rlim, ifw
26861 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
26862 common /tapes/in, ifile, meta
26863 common /dyn/tref, vref
26865 common /faisc/f(10, iptsz), imax, ngood
26866 common /femt/iemgrw, iemqesg
26868 common /etcom/cog(8), exten(17), fd(iptsz)
26869 common /qmoyen/qmoy
26870 common /consta/vl, pi, xmat, rpel, qst
26871 common /bloc23/h, devi, nb, bdb, l
26873 common /poro/irot1, irot2
26874 logical irot1, irot2
26875 common /bloc11/r(6, 6), t(6, 6, 6)
26876 common /bloc21/be, apb(2), layl, layx, rabt
26878 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
26879 common /rander/ialin
26880 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
26881 common /compt/nrres, nrtre, nrbunc, nrdbun
26882 common /radia/trt, rsync, xintf, crae
26883 common /rayshy/iraysh
26885 common /itvole/itvol, imamin
26886 common /tofev/ttvols
26887 common /mcs/imcs, ncstat, cstat(20)
26889 common /isector/nsector, nsprint
26891 logical itvol, imamin, ichaes
26894 dimension xmoy(20), ymoy(20), rmoy(20), rig(20), ncs(20)
26895 dimension xpmoy(20), ypmoy(20)
26896 dimension xcl1(20), xcl2(20), alp(20), sxeb1(20), charge(20)
26897 dimension xsa1b1(20), baims(20)
26899 dimension sbeta(20)
26902 100
format (
' ****** BENDING MAGNET: input list ****** ')
26903 if (baim==0.0)
then 26908 write (16,
'(A,F4.1,A,F12.5,A)')
' Based on reference charge ', qst,
' momentum ', boro,
' (kG.cm)' 26921 write (6, 8254) nrtre, nrres, cr
26922 8254
format (
'Transport element:', i5,
' Accelerating element:', i5, a1, $)
26925 write (16, *)
'***** beam current: ', beamc,
' mA' 26927 write (16, 1010) pent1, rab1, ek1, ek2, apb(1)
26928 1010
format (
' ENTRANCE FACE ******', /,
' ANGLE OF POLE FACE ROTATION ', e12.5,
' DEG', /, &
26929 ' RADIUS OF CURVATURE ', e12.5,
' CM', /,
' FRINGE FIELD CORECTIONS K1 K2', 2(2x,e12.5), /, &
26930 ' VERTICAL HALF-APERTURE ', e12.5,
' CM')
26931 write (16, 1020) rmo, devi, baim, nb, bdb
26932 1020
format (
' WEDGE MAGNET************', /,
' BENDING RADIUS: ', e12.5,
' CM ', /,
' BEND ANGLE: ', e12.5, &
26933 ' DEG', /,
' FIELD: ', e12.5,
' KG', /,
' FIELD GRADIENTS: N ', e12.5,
' BETA:', e12.5)
26935 write (16, 1030) pent2, rab2, sk1, sk2, apb(2)
26936 1030
format (
' EXIT FACE******', /,
' ANGLE OF POLE FACE ROTATION ', e12.5,
' DEG', /, &
26937 ' RADIUS OF CURVATURE ', e12.5,
'CM', /,
' FRINGE FIELD CORRECTIONS K1 K2', 2(2x,e12.5), /, &
26938 ' VERTICAL HALF-APERTURE ', e12.5,
' CM')
26942 dav1(idav, 2) = devi
26943 dav1(idav, 3) = rmo*10.
26944 dav1(idav, 5) = apb(1)*10.
26945 dav1(idav, 6) = pent1
26946 dav1(idav, 7) = ek1
26947 dav1(idav, 8) = ek2
26948 dav1(idav, 9) = rab1*10.
26949 dav1(idav, 10) = pent2
26950 dav1(idav, 11) = sk1
26951 dav1(idav, 12) = sk2
26952 dav1(idav, 13) = rab2*10.
26953 dav1(idav, 14) = nb
26954 dav1(idav, 15) = bdb
26955 dav1(idav, 16) = baim*.1
26956 dav1(idav, 17) = apb(2)*10.
26960 pent1 = pent1*radia
26964 dav1(idav, 1) = l*10.
26966 davtot = davtot + l
26967 dav1(idav, 4) = davtot*10.
26968 pent2 = pent2*radia
26972 devit = devi/float(nsector)
26974 if (devit==pent2) nsector = nsector + 1
26976 if (ichaes .and. (nsector==1)) nsector = 2
26977 devi = devi/float(nsector)
26978 devr = devr/float(nsector)
27001 do nsec = 1, nsector
27007 sdavtot = sdavtot + xlsy
27008 if (nsector>1)
then 27017 if (nsec==nsector)
then 27025 if ((nsec>1) .and. (nsec<nsector))
then 27037 charge(ist) = cstat(ist)
27040 xcl1(ist) = pent1 - xcl2(ist)
27049 if (f(9,i)==charge(ist))
then 27050 xmoy(ist) = xmoy(ist) + f(2, i)
27051 ymoy(ist) = ymoy(ist) + f(4, i)
27052 xpmoy(ist) = xpmoy(ist) + f(3, i)
27053 ypmoy(ist) = ypmoy(ist) + f(5, i)
27054 gpai = f(7, i)/xmat
27055 bpai = sqrt(1.-1./(gpai*gpai))
27056 sbeta(ist) = sbeta(ist) + bpai
27057 xmco = xmat*bpai*gpai
27058 rip = 33.356*xmco*1.e-01/f(9, i)
27059 rig(ist) = rip + rig(ist)
27061 ncs(ist) = ncs(ist) + 1
27064 sbeta(ist) = sbeta(ist)/float(ncs(ist))
27065 xmoy(ist) = xmoy(ist)/float(ncs(ist))
27066 ymoy(ist) = ymoy(ist)/float(ncs(ist))
27067 xpmoy(ist) = xpmoy(ist)/float(ncs(ist))
27068 ypmoy(ist) = ypmoy(ist)/float(ncs(ist))
27069 rig(ist) = rig(ist)/float(ncs(ist))
27071 rmoy(ist) = rig(ist)/baims(ist)
27073 ctan = cos(devi-pent2)/sin(devi-pent2)
27074 xep = rmo*(sin(devi)*ctan-cos(devi))
27075 xepc = xep + rmo - rmoy(ist) + xmoy(ist)
27077 argu = -xmoy(ist)*tan(pent1)/xepc
27081 thet = omga + devi - pent2
27083 eo1 = xepc/cos(omga)
27085 arg1 = eo1*sin(thet)/rmoy(ist)
27088 xeb1 = xepc*cos(thet)/cos(omga) + rmoy(ist)*cos(eta)
27091 xk2b1 = -xmoy(ist)*tan(xcl1(ist)) + xeb1*sin(devi-pent2)
27093 alp(ist) = asin(xk2b1/rmoy(ist))
27095 xeo1 = xepc/cos(omga)
27097 argu = eo1/rmoy(ist)*sin(thet)
27098 xcl2(ist) = asin(argu)
27099 sa1b1 = -rmo*sin(devr)
27100 sa1b1 = sa1b1/sin(devr-pent2)
27101 xsa1b1(ist) = sa1b1 + sxeb1(ist)
27104 baims(ist) = baim*(1.-nb*xsa1b1(ist)/rmo)
27107 baims(ist) = baims(ist) + xb*rih*xsa1b1(ist)*xsa1b1(ist)
27112 ailong = devi*rmoy(ist)
27113 write (16, 101) charge(ist), nsec, nsector, baims(ist), xsa1b1(ist), rmoy(ist), devi*180./pi, ailong, rig(ist)
27114 101
format (/,
' **************************************', /,
' *CENTRAL TRAJECTORY for charge: ', f4.1,
' *', /, &
27115 ' **************************************', /,
' SECTOR: ', i4,
' SECTORS NUMBER: ', i5, /, &
27116 ' BENDING FIELD: ', e12.5,
' kG at: ', e12.5,
' cm', /,
' BENDING RADIUS: ', e12.5,
' CM ', /, &
27117 ' BENDING ANGLE: ', e12.5,
' DEG', /,
' length: ', e12.5,
' cm rigidity: ', e12.5,
' kG.cm')
27128 if (abs(rab1)>6.*0) rabt = 1./rab1
27133 if (f(9,ii)==charge(ist))
then 27134 gcog = gcog + f(7, ii)/xmat
27138 gcog = gcog/float(nii)
27139 bcog = sqrt(1.-1./(gcog*gcog))
27142 if (f(9,ii)==charge(ist))
then 27144 f(2, ii) = f(2, ii) - xmoy(ist)
27145 gpai = f(7, ii)/xmat
27146 bpai = sqrt(1.-1./(gpai*gpai))
27147 f(6, ii) = f(6, ii) + xmoy(ist)*tbe/(bpai*vl)
27148 fd(ii) = (gpai*bpai)/(gcog*bcog)
27149 fdtot = fdtot + fd(ii)
27153 fdtot = fdtot/float(nii) - 1.
27156 write (16, 4502) be*180./pi, charge(ist)
27157 4502
format (
' ****INPUT FACE*** SLOPE: ', e12.5,
' deg ',
'CHARGE: ', f4.1)
27161 if (f(9,ii)==charge(ist))
then 27169 call benmag(sbet, fdtot)
27171 write (16, 4101) charge(ist)
27172 4101
format (
' ****BENDING MAGNET for charge ', f4.1)
27177 if (f(9,ii)==charge(ist))
then 27181 if (iraysh .and. xmat==0.511)
call syrout(ii)
27193 if (abs(rab2)>1.e-10) rabt = 1./rab2
27196 write (16, 4501) be*180./pi, charge(ist)
27197 4501
format (
' ****EXIT FACE*** SLOPE: ', e12.5,
' deg CHARGE: ', f4.1)
27202 if (f(9,ii)==charge(ist))
then 27208 sa1b1 = -rmo*sin(devr)
27209 sa1b1 = sa1b1/sin(devr-pent2)
27210 ttt = xcl2(ist) - pent2
27213 if (f(9,ii)==charge(ist))
then 27215 a1b1 = sa1b1 + sxeb1(ist)
27217 f(2, ii) = (a1b1+f(2,ii)/cos(xcl2(ist)))*cos(pent2)
27219 f(3, ii) = f(3, ii) - ttt
27221 gpai = f(7, ii)/xmat
27222 bpai = sqrt(1.-1./(gpai*gpai))
27223 f(6, ii) = f(6, ii) + r51*xmoy(ist)/(bpai*vl)
27240 pnsec = float(nsec)/2. - nsec/2
27242 if ((pnsec/=0.) .and. (nsec<nsector))
then 27244 write (16, *)
' space charge after sector: ', nsec
27249 if (iraysh .and. xmat==0.511)
call syref 27252 call stapl(sdavtot*10.)
27265 gcog = gcog + f(7, i)/xmat
27266 tcog = tcog + f(6, i)
27268 tcog = tcog/float(ngood)
27269 gcog = gcog/float(ngood)
27270 bcog = sqrt(1.-1./(gcog*gcog))
27271 wcg = (gcog-1.)*xmat
27275 if (iraysh .and. xmat==0.511)
go to 2561
27276 tref = tref + ailong/vref
27280 dav1(idav, 37) = ngood
27281 if (itvol) ttvols = tref
27284 gamref = 1./sqrt(1.-beref*beref)
27285 xmco = xmat*beref*gamref
27286 boro = 33.356*xmco*1.e-01/qst
27288 write (16, 256) beref, gamref, tref, tlong, boro, ngood
27289 256
format (//, 3x,
' *** REFERENCE AT THE EXIT :', /,
' BETA :', e12.5,
' GAMMA :', e12.5, /,
' T.O.F (SEC): ', &
27290 e12.5,
' T.O.F (CM): ', e12.5, /,
' RIGIDITY(KGAUSS.CM) :', e12.5, /,
' NUMBER OF PARTICLES :', i6, /)
27291 if (itvol)
write (16, *)
' tof for adjustments: ', ttvols,
' sec' 27292 if (iemgrw)
call emiprt(0)
27308 implicit real *8(a-z)
27309 common /bloc11/r(6, 6), t(6, 6, 6)
27310 common /edef/avb, drad, kx2, ky2, l
27317 kx = sqrt(abs(kx2))
27318 ky = sqrt(abs(ky2))
27322 avg = sqrt(1.-avb2)
27325 dx = (2.-avb2)*h/kx
27326 dxp = (2.-avb2)*h/kx2
27335 sxp = sinh(argx)*kx
27340 r(1, 6) = dxp*(1.-cx)
27344 r(5, 1) = -dx*sx*kx
27345 r(5, 2) = -dxp*(1.-cx)
27347 r(5, 6) = fdtot*al/avg2 - (2.-avb2)*dxp*h*(al-sx)
27358 r(1, 6) = dxp*(1.-cx)
27363 r(5, 2) = dxp*(1.-cx)
27365 r(5, 6) = fdtot*al/avg2 - (2.-avb2)*dxp*h*(al-sx)
27369 if (kx2==6.*0)
then 27375 r(2, 6) = l*h*(2.-avb2)
27376 r(5, 1) = -l*h*(2.-avb2)
27385 syp = sinh(argy)*ky
27402 if (ky2==6.*0)
then 27427 implicit real *8(a-h, o-z)
27428 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
27429 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
27430 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
27431 common /fene/wdisp, wphas, wx, wy, rlim, ifw
27432 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
27433 common /tapes/in, ifile, meta
27434 common /dyn/tref, vref
27435 common /erigid/edr0
27436 common /faisc/f(10, iptsz), imax, ngood
27437 common /femt/iemgrw, iemqesg
27439 common /etcom/cog(8), exten(17), fd(iptsz)
27440 common /qmoyen/qmoy
27441 common /consta/vl, pi, xmat, rpel, qst
27442 common /edef/avb, drad, kx2, ky2, l
27443 real *8 l, kx2, ky2
27444 common /bloc11/r(6, 6), t(6, 6, 6)
27445 common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
27446 common /rander/ialin
27447 common /cgtof/charm(20), cgtdv(20), nbch(20), netac
27448 common /compt/nrres, nrtre, nrbunc, nrdbun
27449 common /itvole/itvol, imamin
27450 common /tofev/ttvols
27451 common /secdr/iseor
27452 logical iseor, sseor
27453 common /mcs/imcs, ncstat, cstat(20)
27454 logical itvol, imamin, ichaes
27457 dimension xmoy(20), ymoy(20), rmoy(20), rig(20), ncs(20)
27458 dimension xpmoy(20), ypmoy(20), avbt(20), charge(20), alp(20)
27463 write (6, 8254) nrtre, nrres, cr
27464 8254
format (
'Transport element:', i5,
' Accelerating element:', i5, a1, $)
27470 read (in, *) nsector
27471 read (in, *) rm0, devtot, radii, elecf
27473 gd0 = sqrt(1.-bd0*bd0)
27478 edr0 = wt0*bd0*bd0*1.e03/qst
27482 if (elecf>=0.) efd0 = elecf
27483 write (16, 1020) rm0, devtot, radii, edr0, edfnom, efd0, wt0c
27484 1020
format (
' ELECTROSTATIC DEFLECTOR************', /,
' BENDING RADIUS: ', e12.5,
' cm ', /, &
27485 ' BEND ANGLE: ', e12.5,
' deg', /,
' VERTICAL RADII OF CURVATURE: ', e12.5,
' cm', /,
' RIGIDITY: ', &
27486 e12.5,
' kV ', /,
' RADIAL ELECTRIC FIELD (nominal): ', e12.5,
' kV/cm', /, &
27487 ' RADIAL ELECTRIC FIELD (applied): ', e12.5,
' kV/cm', /,
' INPUT ENERGY: ', e12.5,
' MeV', /)
27489 write (16, *)
'***** beam current: ', beamc,
' mA' 27490 if ((iscsp<3) .and. (ncstat>1))
then 27491 write (6, *)
'****************************' 27493 2748
format (
' CAUTION: In the case of multiple charge states', /, &
27494 ' HERSC and SCHERM can not be used for electrostatic bends')
27498 findex = 1. + rm0/radii
27501 dav1(idav, 2) = devtot
27502 dav1(idav, 3) = rm0*10.
27503 dav1(idav, 5) = radii*10.
27504 dav1(idav, 6) = findex
27505 dav1(idav, 7) = edr0
27506 dav1(idav, 8) = efd0*0.1
27508 devtot = devtot*pi/180.
27510 dav1(idav, 1) = l*10.
27512 davtot = davtot + l
27513 dav1(idav, 4) = davtot*10.
27515 if (ichaes .and. (nsector==1)) nsector = 2
27516 devi = devtot/float(nsector)
27517 devr = devtot/float(nsector)
27529 do nsec = 1, nsector
27530 write (6, *)
'********' 27531 write (6, *)
' deflector sector ', nsec
27533 sdavtot = sdavtot + xlsy
27537 charge(ist) = cstat(ist)
27546 if (f(9,i)==charge(ist))
then 27547 xmoy(ist) = xmoy(ist) + f(2, i)
27548 ymoy(ist) = ymoy(ist) + f(4, i)
27549 xpmoy(ist) = xpmoy(ist) + f(3, i)
27550 ypmoy(ist) = ypmoy(ist) + f(5, i)
27551 gpai = f(7, i)/xmat
27552 bpai = sqrt(1.-1./(gpai*gpai))
27553 avbt(ist) = avbt(ist) + bpai
27555 rip = f(7, i)*bpai*bpai/f(9, i)*1.e03
27556 rig(ist) = rip + rig(ist)
27557 ncs(ist) = ncs(ist) + 1
27560 xmoy(ist) = xmoy(ist)/float(ncs(ist))
27561 ymoy(ist) = ymoy(ist)/float(ncs(ist))
27562 xpmoy(ist) = xpmoy(ist)/float(ncs(ist))
27563 ypmoy(ist) = ypmoy(ist)/float(ncs(ist))
27564 rig(ist) = rig(ist)/float(ncs(ist))
27565 rmoy(ist) = rig(ist)/efd0
27566 avbt(ist) = avbt(ist)/float(ncs(ist))
27568 gcog = sqrt(1.-avbt(ist)*avbt(ist))
27572 if (f(9,i)==charge(ist))
then 27573 gpai = f(7, i)/xmat
27574 bpai = sqrt(1.-1./(gpai*gpai))
27575 fd(i) = (gpai*bpai)/(gcog*avbt(ist))
27576 fdtot = fdtot + fd(i)
27580 fdtot = fdtot/float(nii)
27585 oo1 = rm0 - rmoy(ist) + xmoy(ist)
27587 abet = oo1*sin(alp(ist))/rmoy(ist)
27590 alp(ist) = alp(ist) + abet
27592 findex = 1. + rmoy(ist)/radii
27594 kx2 = 3. - findex - avbt(ist)*avbt(ist)
27595 rmoy2 = rmoy(ist)*rmoy(ist)
27597 ky2 = (findex-1.)/rmoy2
27600 ailong = devi*rmoy(ist)
27609 write (16, 4101) charge(ist), nsec, nsector, efd0, rig(ist), findex, kx2, ky2, rmoy(ist), devi*180./pi, ailong
27610 4101
format (/,
' **************************************', /,
' *CENTRAL TRAJECTORY for charge: ', f4.1,
' *', /, &
27611 ' **************************************', /,
' SECTOR: ', i4,
' SECTORS NUMBER: ', i5, /, &
27612 ' RADIAL FIELD: ', e12.5,
' kV*cm-1: ', /,
' RIGIDITY: ', e12.5,
' kV ', /,
' FIELD INDEX: ', e12.5, &
27613 ' PARAMETER Kx: ', e12.5,
' cm-2 PARAMETER Ky: ', e12.5,
' cm-2', /,
' BENDING RADIUS: ', e12.5,
' cm ', &
27614 ' BENDING ANGLE: ', e12.5,
' deg', /,
' LENGTH: ', e12.5,
' cm', /)
27623 if (f(9,ii)==charge(ist))
then 27630 ec = -rmoy(ist)*cos(abet) - oo1*sin(devi) + rm0
27632 if (f(9,ii)==charge(ist))
then 27634 f(2, ii) = f(2, ii)*cos(abet) - ec
27636 f(3, ii) = f(3, ii) - abet*1.e03
27638 gpai = f(7, ii)/xmat
27639 bpai = sqrt(1.-1./(gpai*gpai))
27640 f(6, ii) = f(6, ii) + r51*xmoy(ist)/(bpai*vl)
27649 pnsec = float(nsec)/2. - nsec/2
27651 if ((pnsec/=0.) .and. (nsec<nsector))
then 27653 write (6, *)
' space charge after sector: ', nsec
27658 call stapl(sdavtot*10.)
27671 gcog = gcog + f(7, i)/xmat
27672 tcog = tcog + f(6, i)
27674 tcog = tcog/float(ngood)
27675 gcog = gcog/float(ngood)
27676 bcog = sqrt(1.-1./(gcog*gcog))
27677 wcg = (gcog-1.)*xmat
27681 tref = tref + ailong/vref
27685 dav1(idav, 36) = ngood
27686 if (itvol) ttvols = tref
27687 if (itvol)
write (16, *)
' tof for adjustments: ', ttvols,
' sec' 27688 if (iemgrw)
call emiprt(0)
27698 subroutine cesp(xlqua)
27699 implicit real *8(a-h, o-z)
27700 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
27701 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
27702 common /cdek/dwp(iptsz)
27704 common /faisc/f(10, iptsz), imax, ngood
27705 common /mcs/imcs, ncstat, cstat(20)
27706 logical ichaes, iesp, isepa
27713 if (.not. ichaes)
return 27715 if ((iscsp/=3) .and. (ncstat>1))
then 27716 write (6, *)
'****************************' 27718 2748
format (
' ERROR: Wrong space charge model chosen', /,
' With multiple charge states in the beam', /, &
27719 ' only the SCHEFF routine should be used')
27724 write (16, *)
'space charge length(cm): ', scdist
27734 if (ncstat==1)
call scheff1(1)
27742 if (.not. isepa)
call scheff1(1)
27746 end subroutine cesp 27751 subroutine sizer(ist, xrms, yrms, zrms)
27752 implicit real *8(a-h, o-z)
27753 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
27754 common /part/xc(iptsz), yc(iptsz), zc(iptsz)
27755 common /cgrms/xsum, ysum, zsum
27756 common /faisc/f(10, iptsz), imax, ngood
27757 common /mcs/imcs, ncstat, cstat(20)
27767 if (f(9,i)==cstat(ist))
then 27769 xsum = xsum + xc(i)
27770 ysum = ysum + yc(i)
27771 zsum = zsum + zc(i)
27772 xsqsum = xsqsum + xc(i)*xc(i)
27773 ysqsum = ysqsum + yc(i)*yc(i)
27774 zsqsum = zsqsum + zc(i)*zc(i)
27777 xsum = xsum/float(ngist)
27778 ysum = ysum/float(ngist)
27779 zsum = zsum/float(ngist)
27780 xsqsum = xsqsum/float(ngist)
27781 ysqsum = ysqsum/float(ngist)
27782 zsqsum = zsqsum/float(ngist)
27783 xrms = sqrt(xsqsum-xsum*xsum)
27784 yrms = sqrt(ysqsum-ysum*ysum)
27785 zrms = sqrt(zsqsum-zsum*zsum)
27787 end subroutine sizer 27796 implicit real *8(a-h, o-z)
27797 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
27798 common /faisc/f(10, iptsz), imax, ngood
27799 common /qmoyen/qmoy
27800 common /part/xc(iptsz), yc(iptsz), zc(iptsz)
27801 common /consta/vl, pi, xmat, rpel, qst
27802 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
27803 common /azlist/icont, iprin
27804 common /mcs/imcs, ncstat, cstat(20)
27811 if (f(9,i)==cstat(ist))
then 27813 grmoy = grmoy + f(7, i)/xmat
27814 trmoy = trmoy + f(6, i)
27815 xbax = xbax + f(2, i)
27818 trmoy = trmoy/float(ngist)
27819 grmoy = grmoy/float(ngist)
27820 brmoy = sqrt(1.-1./(grmoy*grmoy))
27821 xbax = xbax/float(ngist)
27845 if (f(9,np)==cstat(ist))
then 27846 gpai = f(7, np)/xmat
27847 bpai = sqrt(1.-1./(gpai*gpai))
27851 znp = (trmoy-f(6,np))*bpai*vl
27853 zc(np) = znp*cos(apl) + xnp*sin(apl)
27854 xnp = xnp*cos(apl) - znp*sin(apl)
27856 f3 = f(3, np)*1.e-03
27857 f5 = f(5, np)*1.e-03
27859 xc(np) = (xnp+zc(np)*f3)/100.
27860 yc(np) = (f(4,np)+zc(np)*f5)/100.
27861 zc(np) = zc(np)/100.
27869 if (f(9,np)==cstat(ist))
then 27870 xbar = xbar + xc(np)
27871 ybar = ybar + yc(np)
27872 zbar = zbar + zc(np)
27875 xbar = xbar/float(ngist)
27876 ybar = ybar/float(ngist)
27877 zbar = zbar/float(ngist)
27881 if (f(9,np)==cstat(ist))
then 27882 xc(np) = xc(np) - xbar
27883 yc(np) = yc(np) - ybar
27884 zc(np) = zc(np) - zbar
27893 subroutine b_sep(isepa)
27894 implicit real *8(a-h, o-z)
27895 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
27896 common /part/xc(iptsz), yc(iptsz), zc(iptsz)
27897 common /cgrms/xsum, ysum, zsum
27898 common /faisc/f(10, iptsz), imax, ngood
27899 common /mcs/imcs, ncstat, cstat(20)
27900 common /consta/vl, pi, xmat, rpel, qst
27901 dimension d11(2), d22(2), d12(2), rp12(2), xpint(2), xint(2)
27907 if (cstat(i)>csmax1)
then 27915 if (cstat(i)>csmax2)
then 27928 if (f(9,i)==csmax1)
then 27929 xg1 = xg1 + f(2, i)
27930 xpg1 = xpg1 + f(3, i)
27933 if (f(9,i)==csmax2)
then 27934 xg2 = xg2 + f(2, i)
27935 xpg2 = xpg2 + f(3, i)
27939 xg1 = xg1/float(imax1)
27940 xpg1 = xpg1/float(imax1)
27941 xg2 = xg2/float(imax2)
27942 xpg2 = xpg2/float(imax2)
27951 if (f(9,i)==csmax1)
then 27952 d11(1) = d11(1) + (f(3,i)-xpg1)**2
27953 d22(1) = d22(1) + (f(2,i)-xg1)**2
27954 d12(1) = d12(1) + (f(3,i)-xpg1)*(f(2,i)-xg1)
27956 if (f(9,i)==csmax2)
then 27957 d11(2) = d11(2) + (f(3,i)-xpg2)**2
27958 d22(2) = d22(2) + (f(2,i)-xg2)**2
27959 d12(2) = d12(2) + (f(3,i)-xpg2)*(f(2,i)-xg2)
27962 d11(1) = d11(1)/float(imax1)
27963 d22(1) = d22(1)/float(imax1)
27964 d12(1) = d12(1)/float(imax1)
27965 d11(2) = d11(2)/float(imax2)
27966 d22(2) = d22(2)/float(imax2)
27967 d12(2) = d12(2)/float(imax2)
27968 rp12(1) = d12(1)/sqrt(d11(1)*d22(1))
27969 rp12(2) = d12(2)/sqrt(d11(2)*d22(2))
27970 xpint(1) = sqrt(d11(1)*(1.-rp12(1)))
27971 xint(1) = sqrt(d22(1)*(1.-rp12(1)))
27972 xpint(2) = sqrt(d11(2)*(1.-rp12(2)))
27973 xint(2) = sqrt(d22(2)*(1.-rp12(2)))
27975 elip1 = xpg1 + xpint(1)
27976 elip2 = xpg2 - xpint(2)
27977 if (elip1<elip2) isepa = .true.
27985 end subroutine b_sep 28016 implicit real *8(a-h, o-z)
28017 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
28018 common /dyn/tref, vref
28019 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
28020 common /consta/vl, pi, xmat, rpel, qst
28021 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
28022 common /faisc/f(10, iptsz), imax, ngood
28025 common /stsc/beami, wavel, freq, btazero, frrms, fzrms, nr, nz
28026 common /stsc1/beams, im1, im2, im3, nr1, nz1, nq
28027 common /fldcom/rp, zp, pl, opt, nip
28029 common /rcshef/sce(20)
28030 common /conti/irfqp
28035 gmoy = f(7, np)/xmat + gmoy
28037 gmoy = gmoy/float(ngood)
28038 bgmoy = sqrt(gmoy*gmoy-1.)
28039 beams = beamc/1000.0
28040 wavel = 2.*pi*vl/fh
28046 nip = idint(sce(6))
28049 if (irfqp) pl = pl/2.
28051 if (sce(7)>0.) pl = sce(7)*gmoy
28099 implicit real *8(a-h, o-z)
28100 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
28101 common /dyn/tref, vref
28103 common /part/xc(iptsz), yc(iptsz), zc(iptsz)
28104 common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
28105 common /hermt/afxt(22), afyt(22), afzt(22)
28106 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
28107 common /consta/vl, pi, xmat, rpel, qst
28108 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
28109 common /faisc/f(10, iptsz), imax, ngood
28110 common /cdek/dwp(iptsz)
28111 common /beamsa/fs(7, iptsz)
28113 common /compt/nrres, nrtre, nrbunc, nrdbun
28115 logical ichaes, iesp
28116 common /bg/bsc, gsc, phis, wsync
28117 common /stsc/beami, wavel, freq, btazero, frrms, fzrms, nr, nz
28118 common /stsc1/beams, im1, im2, im3, nr1, nz1, nq
28119 common /fldcom/rp, zp, pl, opt, nip
28120 common /spacech1/rm(21), zm(41), rs(20), ers(16800), ezs(16800), ez(861), aa(800), rssq(20), zzs(41), er(861), &
28121 rss(20), ismax(40), iemax(41)
28122 common /rcshef/sce(20)
28123 common /conti/irfqp
28126 common /fcont/ifcont
28143 gmoy = f(7, np)/xmat + gmoy
28145 gmoy = gmoy/float(ngood)
28147 if (beami==0. .or. scdist==0.)
return 28152 call sizrms(0, xrms, yrms, zrms, zz)
28154 write (16, 6875) iell, xrms, yrms, zrms
28158 6875
format (
' Cell ', i4,
' RMS size(m)', e12.5, 2x, e12.5, 2x, e12.5)
28159 rrms = sqrt(xrms*xrms+yrms*yrms)
28163 dr = rrms*frrms/float(nr)
28164 dz = zrms1*fzrms/float(nz)
28165 rmax = float(nr)*dr
28169 rm(i) = float(i-1)*dr
28170 rssq(i-1) = .5*(rm(i-1)**2+rm(i)**2)
28171 rss(i-1) = 0.5*(rm(i-1)+rm(i))
28172 rs(i-1) = sqrt(rssq(i-1))
28176 zm(i) = float(i-1)*dz
28177 zzs(i) = zm(i) + zs
28184 q = beami/(freq*float(nq))
28185 c1 = 572167.*q/xmat
28188 rfac = (rm(k+1)**2-rm(k)**2)*dz/2.
28189 if (opt==0.) rfac = 1.
28194 if (opt==0.)
call flds(rs(k), zs, er1, ez1)
28195 if (opt==0.)
go to 35
28196 call gaus(rm(k), rm(k+1), zm(1), zm(2), opt, er1, ez1)
28198 ers(l) = c1*er1/rfac
28202 ezs(l) = c1*ez1/rfac
28206 if (beamc==0. .or. scdist==0.)
return 28221 gpai = f(7, np)/xmat
28222 brmoy = brmoy + sqrt(1.-1./(gpai*gpai))
28223 trmoy = trmoy + f(6, np)
28225 trmoy = trmoy/float(ngood)
28228 beta = brmoy/float(ngood)
28229 gsc = 1./sqrt(1.-beta*beta)
28234 c2 = beta*wavel/(2.*pi)
28260 epsq = sqrt((xsq-xbar*xbar)/(ysq-ybar*ybar))
28262 xfac = 2./(epsq+1.)
28270 rsq = (f(2,np)-xbar)**2*epsqi + (f(4,np)-ybar)**2*epsq
28274 i = idint(r/dr+1.0)
28275 if (i>nr)
go to 120
28277 z = -c2*(zph-phimc)
28278 if (abs(z)>=hl)
go to 120
28282 jm1 = idint(zz/dz+1.)
28285 if (rsq<rss(i)) i1 = i - 1
28289 if (zz<zzs(jm1)) j1 = jm1 - 1
28298 sqr = sqrt(4.*rdr2-1.)
28299 rminsq = (halfdr*(sqr-1.))**2
28300 rmaxsq = (halfdr*(sqr+1.))**2
28302 a = (rmaxsq-rm(i)**2)/(rmaxsq-rminsq)
28304 a = (rm(i1)**2-rminsq)/(rmaxsq-rminsq)
28318 if (j1/=jm1) cc = (zz-zzs(j1))/(zzs(jm1)-zzs(j1))
28321 aa(k) = aa(k) + a*cc
28323 aa(k) = aa(k) + b*cc
28325 aa(k) = aa(k) + a*d
28327 aa(k) = aa(k) + b*d
28335 if (aa(m)<=0.00)
then 28346 iemax(1) = 1 + ismax(1)
28348 iemax(j) = 1 + max0(ismax(j-1), ismax(j))
28350 iemax(nz1) = 1 + ismax(nz)
28360 if (ism==0)
go to 220
28364 if (a1==0.)
go to 210
28367 k1 = l + (js-je)*nr1
28370 if (iem<=1)
go to 180
28374 er(n) = er(n) + a1*ers(k)
28375 ez(n) = ez(n) - a1*ezs(k)
28379 k1 = l + (je-js1)*nr1
28382 if (iem<=1)
go to 200
28386 er(n) = er(n) + a1*ers(k)
28387 ez(n) = ez(n) + a1*ezs(k)
28402 dwc = f(7, np) - xmat
28405 f3np = f(3, np)*1.e-03
28406 f5np = f(5, np)*1.e-03
28408 bgz = sqrt(gm1*(2.+gm1))
28414 bgzstar = gam*(bgz-beta*gamma)
28418 gstar = gam*(gamma-beta*bgz)
28420 r = sqrt((f(2,np)-xbar)**2*epsqi+(f(4,np)-ybar)**2*epsq)
28421 if (r>=rrmax) rrmax = r
28422 if (r==0.) r = .000001
28423 xor = (f(2,np)-xbar)*xfac/r
28424 yor = (f(4,np)-ybar)*yfac/r
28430 z = -c2*(zph-phimc)
28431 if (z>=zzmax) zzmax = z
28432 if (z<zzmin) zzmin = z
28433 if (abs(z)>hl)
then 28440 a = rb - float(i-1)
28444 c = zb - float(j-1)
28448 cbgr = c3*(d*(a*er(l+1)+b*er(l))+c*(a*er(m+1)+b*er(m)))
28449 cbgzs = c3*(d*(a*ez(l+1)+b*ez(l))+c*(a*ez(m+1)+b*ez(m)))
28457 cbgr = cbgr*abs(f(9,np))
28458 cbgzs = cbgzs*abs(f(9,np))
28463 d = sqrt(z**2+r**2)
28466 if (nip==0)
go to 250
28472 d = sqrt(s**2+r**2)
28473 rod3 = rod3 + r/d**3
28474 zod3 = zod3 + s/d**3
28480 250 cbgr = eng*c1*c3*rod3*pi/2.
28481 cbgzs = eng*c1*c3*zod3*pi/2.
28483 cbgr = cbgr*abs(f(9,np))
28484 cbgzs = cbgzs*abs(f(9,np))
28488 260 bgx = bgx + cbgr*xor
28489 bgy = bgy + cbgr*yor
28491 bgzstar = bgzstar + cbgzs
28492 gstar = 1. + 0.5*bgzstar**2
28493 bgzf = gam*(bgzstar+beta*gstar)
28496 dww = f(7, np) - xmat
28497 dws = dww*((gamma+1.)/gamma)*(bgzf-bgz)/bgz
28501 if (.not. iesp)
then 28504 f(js, np) = fs(js, np)
28510 f(3, np) = f(3, np) + dxp*1000.
28511 f(5, np) = f(5, np) + dyp*1000.
28512 f(2, np) = f(2, np) - dz1*100.*dxp*xpsc
28513 f(4, np) = f(4, np) - dz1*100.*dyp*xpsc
28516 f(3, np) = f3*1000.
28517 f(5, np) = f5*1000.
28518 f(7, np) = f(7, np) + dws
28559 implicit real *8(a-h, o-z)
28560 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
28561 common /dyn/tref, vref
28563 common /part/xc(iptsz), yc(iptsz), zc(iptsz)
28564 common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
28565 common /hermt/afxt(22), afyt(22), afzt(22)
28566 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
28567 common /consta/vl, pi, xmat, rpel, qst
28568 common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
28569 common /faisc/f(10, iptsz), imax, ngood
28570 common /cdek/dwp(iptsz)
28571 common /beamsa/fs(7, iptsz)
28573 common /compt/nrres, nrtre, nrbunc, nrdbun
28575 logical ichaes, iesp
28576 common /bg/bsc, gsc, phis, wsync
28577 common /stsc/beami, wavel, freq, btazero, frrms, fzrms, nr, nz
28578 common /stsc1/beams, im1, im2, im3, nr1, nz1, nq
28579 common /fldcom/rp, zp, pl, opt, nip
28580 common /spacech1/rm(21), zm(41), rs(20), ers(16800), ezs(16800), ez(861), aa(800), rssq(20), zzs(41), er(861), &
28581 rss(20), ismax(40), iemax(41)
28582 common /rcshef/sce(20)
28583 common /mcs/imcs, ncstat, cstat(20)
28584 common /conti/irfqp
28587 if (beams==0. .or. scdist==0.)
return 28590 write (16, *)
' ****SCHEFF ', iell
28591 write (16, *)
' states charges ', ncstat
28596 if (f(9,np)==cstat(isp))
then 28598 gmoy = f(7, np)/xmat + gmoy
28601 gmoy = gmoy/float(ngisp)
28603 beamc = beams*ngisp/ngood
28606 call sizer(isp, xrms, yrms, zrms)
28607 write (16, 6875) cstat(isp), beamc, xrms, yrms, zrms
28611 6875
format (
' charge: ', f8.0,
' bunch intensity: ', e12.5,
' amp', /,
' with RMS size(m)', e12.5, 2x, e12.5, 2x, &
28613 rrms = sqrt(xrms*xrms+yrms*yrms)
28617 dr = rrms*frrms/float(nr)
28618 dz = zrms1*fzrms/float(nz)
28619 rmax = float(nr)*dr
28623 rm(i) = float(i-1)*dr
28624 rssq(i-1) = .5*(rm(i-1)**2+rm(i)**2)
28625 rss(i-1) = 0.5*(rm(i-1)+rm(i))
28626 rs(i-1) = sqrt(rssq(i-1))
28630 zm(i) = float(i-1)*dz
28631 zzs(i) = zm(i) + zs
28638 q = beami/(freq*float(nq))
28639 c1 = 572167.*q/xmat
28642 rfac = (rm(k+1)**2-rm(k)**2)*dz/2.
28643 if (opt==0.) rfac = 1.
28648 if (opt==0.)
call flds(rs(k), zs, er1, ez1)
28649 if (opt==0.)
go to 35
28650 call gaus(rm(k), rm(k+1), zm(1), zm(2), opt, er1, ez1)
28652 ers(l) = c1*er1/rfac
28653 ezs(l) = c1*ez1/rfac
28671 if (f(9,np)==cstat(isp))
then 28672 gpai = f(7, np)/xmat
28673 brmoy = brmoy + sqrt(1.-1./(gpai*gpai))
28674 trmoy = trmoy + f(6, np)
28677 trmoy = trmoy/float(ngisp)
28680 beta = brmoy/float(ngisp)
28681 gsc = 1./sqrt(1.-beta*beta)
28686 c2 = beta*wavel/(2.*pi)
28696 if (f(9,np)==cstat(isp))
then 28714 epsq = sqrt((xsq-xbar*xbar)/(ysq-ybar*ybar))
28716 xfac = 2./(epsq+1.)
28724 if (f(9,np)==cstat(isp))
then 28725 rsq = (f(2,np)-xbar)**2*epsqi + (f(4,np)-ybar)**2*epsq
28729 i = idint(r/dr+1.0)
28730 if (i>nr)
go to 120
28732 z = -c2*(zph-phimc)
28733 if (abs(z)>=hl)
go to 120
28737 jm1 = idint(zz/dz+1.)
28740 if (rsq<rss(i)) i1 = i - 1
28744 if (zz<zzs(jm1)) j1 = jm1 - 1
28753 sqr = sqrt(4.*rdr2-1.)
28754 rminsq = (halfdr*(sqr-1.))**2
28755 rmaxsq = (halfdr*(sqr+1.))**2
28757 a = (rmaxsq-rm(i)**2)/(rmaxsq-rminsq)
28759 a = (rm(i1)**2-rminsq)/(rmaxsq-rminsq)
28764 if (j1/=jm1) cc = (zz-zzs(j1))/(zzs(jm1)-zzs(j1))
28767 aa(k) = aa(k) + a*cc
28769 aa(k) = aa(k) + b*cc
28771 aa(k) = aa(k) + a*d
28773 aa(k) = aa(k) + b*d
28783 if (aa(m)<=0.00)
then 28794 iemax(1) = 1 + ismax(1)
28796 iemax(j) = 1 + max0(ismax(j-1), ismax(j))
28798 iemax(nz1) = 1 + ismax(nz)
28808 if (ism==0)
go to 220
28812 if (a1==0.)
go to 210
28815 k1 = l + (js-je)*nr1
28818 if (iem<=1)
go to 180
28822 er(n) = er(n) + a1*ers(k)
28823 ez(n) = ez(n) - a1*ezs(k)
28827 k1 = l + (je-js1)*nr1
28830 if (iem<=1)
go to 200
28834 er(n) = er(n) + a1*ers(k)
28835 ez(n) = ez(n) + a1*ezs(k)
28849 if (f(9,np)==cstat(isp))
then 28850 dwc = f(7, np) - xmat
28853 f3np = f(3, np)*1.e-03
28854 f5np = f(5, np)*1.e-03
28856 bgz = sqrt(gm1*(2.+gm1))
28862 bgzstar = gam*(bgz-beta*gamma)
28866 gstar = gam*(gamma-beta*bgz)
28868 r = sqrt((f(2,np)-xbar)**2*epsqi+(f(4,np)-ybar)**2*epsq)
28869 if (r>=rrmax) rrmax = r
28870 if (r==0.) r = .000001
28871 xor = (f(2,np)-xbar)*xfac/r
28872 yor = (f(4,np)-ybar)*yfac/r
28878 z = -c2*(zph-phimc)
28879 if (z>=zzmax) zzmax = z
28880 if (z<zzmin) zzmin = z
28881 if (abs(z)>hl)
then 28888 a = rb - float(i-1)
28892 c = zb - float(j-1)
28896 cbgr = c3*(d*(a*er(l+1)+b*er(l))+c*(a*er(m+1)+b*er(m)))
28897 cbgzs = c3*(d*(a*ez(l+1)+b*ez(l))+c*(a*ez(m+1)+b*ez(m)))
28898 cbgr = cbgr*abs(f(9,np))
28899 cbgzs = cbgzs*abs(f(9,np))
28904 d = sqrt(z**2+r**2)
28907 if (nip==0)
go to 250
28913 d = sqrt(s**2+r**2)
28914 rod3 = rod3 + r/d**3
28915 zod3 = zod3 + s/d**3
28921 250 cbgr = eng*c1*c3*rod3*pi/2.
28922 cbgzs = eng*c1*c3*zod3*pi/2.
28923 cbgr = cbgr*abs(f(9,np))
28924 cbgzs = cbgzs*abs(f(9,np))
28928 260 bgx = bgx + cbgr*xor
28929 bgy = bgy + cbgr*yor
28930 bgzstar = bgzstar + cbgzs
28931 gstar = 1. + 0.5*bgzstar**2
28932 bgzf = gam*(bgzstar+beta*gstar)
28935 dww = f(7, np) - xmat
28936 dws = dww*((gamma+1.)/gamma)*(bgzf-bgz)/bgz
28938 if (.not. iesp)
then 28941 f(js, np) = fs(js, np)
28947 f(3, np) = f(3, np) + dxp*1000.
28948 f(5, np) = f(5, np) + dyp*1000.
28949 f(2, np) = f(2, np) - dz1*100.*dxp*xpsc
28950 f(4, np) = f(4, np) - dz1*100.*dyp*xpsc
28953 f(3, np) = f3*1000.
28954 f(5, np) = f5*1000.
28955 f(7, np) = f(7, np) + dws
28982 subroutine rfkick(v, dp, harm, nvf)
28983 implicit real *8(a-h, o-z)
28984 parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
28986 common /consta/vl, pi, xmat, rpel, qst
28987 common /dyn/tref, vref
28988 common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
28989 common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
28990 common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
28991 common /faisc/f(10, iptsz), imax, ngood
28992 common /etcom/cog(8), exten(17), fd(iptsz)
28993 common /fene/wdisp, wphas, wx, wy, rlim, ifw
28994 common /corec/tref1
28995 common /qmoyen/qmoy
28996 common /aerp/vphase, vfield, ierpf
28997 common /itvole/itvol, imamin
28998 common /compt/nrres, nrtre, nrbunc, nrdbun
28999 common /shif/dtiph, shift
29000 common /tofev/ttvols
29003 logical chasit, itvol, imamin, shift
29005 call stapl(davtot*10.)
29013 write (6, 8254) nrtre, cr
29014 8254
format (
'Transport element:', i5, a1, $)
29015 if (harm<=0.) harm = 1.
29022 tcog = tcog + f(6, np)
29023 gpa = f(7, np)/xmat
29024 bcog = sqrt(1.-1./(gpa*gpa)) + bcog
29026 tcog = tcog/float(ngood)
29027 bcog = bcog/float(ngood)
29028 gcog = 1./sqrt(1.-bcog*bcog)
29029 encog = xmat*gcog - xmat
29033 ttvpi = harm*ttvols*fcpi
29036 xkpi = (xkpi-float(ixkpi))*360.
29037 write (16, *)
' *** TOF correction:', -xkpi,
' deg' 29038 dp = dp - xkpi*pi/180.
29039 write (16, *)
' ***phase of RF adjusted : ', dp*180./pi,
' deg' 29045 dav1(idav, 2) = dp*180./pi
29046 dav1(idav, 3) = nvf
29047 dav1(idav, 4) = davtot*10.
29049 dav1(idav, 5) = harm
29052 178
format (/,
' Longitudinal parameters', /, 5x,
' BETA GAMMA ENERGY(MeV) ', &
29053 ' TOF(deg) TOF(sec)')
29054 write (16, 1788) bcog, gcog, encog, tcog*fcpi, tcog
29055 1788
format (
' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
29056 e0t = harm*v/(bcog*wavel)
29057 cay = harm*twopi/(bcog*gcog*wavel)
29059 con = twopi*e0t*qmoy/xmat
29069 gamref = 1./sqrt(1.-beref*beref)
29070 older = xmat*gamref
29076 gamref = 1./sqrt(1.-beref*beref)
29077 older = xmat*gamref
29080 enrprin = older - xmat
29081 write (16, 165) beref, gamref, enrprin, tref*fh*180./pi, tref
29082 165
format (
' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
29087 a = harm*(f(6,np)-tref+ttvols)*fh + dp
29089 w = f(7, np) - xmat
29090 gpai = f(7, np)/xmat
29091 bg = sqrt(w/xmat*(2.+w/xmat))
29093 const = (gpai/(gpai*gpai-1.))*f(9, np)
29094 disp = const*v/xmat*s
29095 bcour = bcour + bpai
29096 tcog = tcog + f(6, np)
29098 f(3, np) = f(3, np) +
disp 29099 else if (nvf==1)
then 29100 f(5, np) = f(5, np) +
disp 29102 write (6, *)
'Invalid parameter NVF in RFKICK' 29106 wsync = wsync/float(ngood)
29107 bcour = bcour/float(ngood)
29108 tcog = tcog/float(ngood)
29112 dav1(idav, 36) = ngood
subroutine scheff1_swesson(int)
subroutine xtypm(gami, saphi, qsc, dcg)
function varxy(xi, xf, ik)
function variz(bb, cc, dd, ee, ee1)
function sgppp(it1, it2, it3)
subroutine table(lbmax, mbmax, nbmax)
function epip(it1, it2, it3)
function denpd(xyz, nmaxy, nmaz)
function eipp(it1, it2, it3)
subroutine sizrms(imaxd, xrms, yrms, zrms, zmin)
function sppp(it1, it2, it3)
subroutine boucle(ipas, gamref, saphi, dcum, delphr)
function epii(it1, it2, it3)
subroutine xtypl2(gami, saphi, qsc, dcg)
function varzr(ee, cc, nmazr)
subroutine xtypl1(gami, saphi, qsc, dcg)
subroutine rluxat(lout, inout, k1, k2)
function codsy(bb, cc, dd, ee, kap)
function sgiii(it1, it2, it3)
subroutine dwref(phi0, gam5, t5)
function prinz(cc, dd, kap, zrmss1)
subroutine sizcor(ect, xrms, yrms, zrms, imaxd)
function copdr(xi, xf, kap)
subroutine fieldcav(atte)
function uppp(it1, it2, it3)
subroutine benmag(sbet, fdtot)
function sipp(it1, it2, it3)
subroutine fdrift(xl, npart, imit)
subroutine intfac(tofini)
function sgpip(it1, it2, it3)
subroutine mfordre(rc, ra, rb)
function xitl3(gami, gams, betr, nit, saphi, qqc)
subroutine accep_rfq(pib)
subroutine steer(fld, nvf)
function sgipi(it1, it2, it3)
function eiii(it1, it2, it3)
subroutine tiltbm_bis(icg)
function eppi(it1, it2, it3)
function upip(it1, it2, it3)
subroutine fldsol(dbs, step)
function varia(bb, cc, dd, ee)
function spip(it1, it2, it3)
subroutine sextu(imk2, arg, xlsex, rg)
subroutine flds(r, z, er, ez)
subroutine bcnum(phref, ylg, ncell)
subroutine solnoid(imks, arg, xlsol)
function sgpii(it1, it2, it3)
function codif(bb, cc, dd, ee, ee1, kap)
subroutine prbeam(iflg, wfile)
subroutine phcrest1(phi0, ylg, ncell)
function spii(it1, it2, it3)
subroutine gap(gamref, saphi, gams, delphr)
function sppi(it1, it2, it3)
subroutine rchsom(zi, zf, nmaz)
function dendif(z, aa, bb, cc, dd)
subroutine xtylpk(gami, saphi, qsc, dcg)
subroutine intga(npt, ireca)
function eiip(it1, it2, it3)
function sgppi(it1, it2, it3)
function tppp(it1, it2, it3)
function eppp(it1, it2, it3)
subroutine phcrest(phi0, ylg, ncell, zcrest)
subroutine solquad(iksq, args, argq, xlsol, rg)
function tpii(it1, it2, it3)
subroutine randga(len, s, am, v)
function xitl0(gami, gams, betr, saphi, qqc)
function sipi(it1, it2, it3)
subroutine egun(fmult, indp)
function densy(m, y, ireca)
subroutine rlux(rvec, lenv)
subroutine tdens(m, ireca, iacc)
function upii(it1, it2, it3)
function sgiip(it1, it2, it3)
subroutine xtypj(gami, saphi, qsc, dcg)
function grz(aa, bb, cc, dd, ee)
subroutine qelec(volt, xlqua, rs)
function uiii(it1, it2, it3)
subroutine rchsor(aa, bb, cc, dd, zs)
function tpip(it1, it2, it3)
function corxy(xi, xf, kap, ik, xyrms)
function xitl2(gami, gams, betr, saphi, qqc)
function drxyz(m, xyz, ireca)
subroutine bunparm(v, dp, harm, prlim)
subroutine qasex(iksq, args, argq, xlqua, rg)
subroutine rluxin(isdext)
subroutine sizer(ist, xrms, yrms, zrms)
subroutine crest(betr, eqvl, xpos, bkcr, ffield)
function dendir(z, aa, bb, cc, dd, ee)
function tppi(it1, it2, it3)
subroutine qalva(bquad, xlqua, rg)
function tiip(it1, it2, it3)
subroutine gaus(r1, r2, z1, z2, opt, er, ez)
function siip(it1, it2, it3)
subroutine eint(a, ee, ek)
function tipp(it1, it2, it3)
subroutine rluxgo(lux, ins, k1, k2)
subroutine aimalv(angl, rmo, baim, xn, xb, ek1, ek2, pent1, rab1, sk1, sk2, pent2, rab2)
function tiii(it1, it2, it3)
subroutine rluxut(isdext)
function gamci(phi, pcresi, gami, ist, qsc)
function uiip(it1, it2, it3)
function uppi(it1, it2, it3)
function siii(it1, it2, it3)
subroutine cobeam(ii, xl)
subroutine gcern(len, s, am, v)
subroutine mytime(iitime)
subroutine qfk(ityqu, arg, xlqua, rs)
function xi1(phi0, t0, t5)
subroutine rfkick(v, dp, harm, nvf)
function densz(m, z, ireca)
function densx(m, x, ireca)
subroutine xtyplp1(gami, saphi, qsc, dcg)
subroutine fposbbb(xlcum, fposs, jx)
function sgipp(it1, it2, it3)
function eipi(it1, it2, it3)
function uipi(it1, it2, it3)
subroutine grcomp(text, iskale)
subroutine rgaus2(sigma, y1, y2, y3, y4)
subroutine fielde(lc, mc, nc, isucc)
function uipp(it1, it2, it3)
function tipi(it1, it2, it3)
subroutine deflect(fdtot)
subroutine solfield(bcret, intgr)
subroutine corre(n, nall)